perm filename PARSE.OLD[AL,HE]14 blob
sn#501013 filedate 1980-04-01 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00057 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 UPDATES TO PARSE BY MSM
C00012 00003 the AL to S-expression translator AND MSM SWITCHES
C00017 00004 ! statement, operator, sex, require, move definitions
C00023 00005 ! brace, condition_monitor, dimension, misc reserved word definitions
C00025 00006 ! dec_name, declaration names for input and output
C00027 00007 ! operators
C00029 00008 ! reserved_words
C00032 00009 ! init_reserved
C00034 00010 ! predefined constants
C00037 00011 ! predefined macros
C00040 00012 ! compiler switches and control tables
C00043 00013 ! hash, declaration of debugging variables, start of hidden_parse
C00046 00014 ! ---- DECLARATIONS ----
C00052 00015 ! record declarations
C00058 00016 ! other declarations
C00060 00017 ! error, error_recovery, error_reject, print, file_indent
C00076 00018 ! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy
C00084 00019 ! push_source_list,pop_source_list,new_expr_rec
C00086 00020 ! id info processing routines
C00092 00021 ! read
C00097 00022 ! macro handling routine
C00103 00023 ! expand_macro
C00108 00024 ! get_token
C00121 00025
C00125 00026 ! check, inverse, multiply and divide dimensions ! CHECK_EXP_TYPE_DIMENS
C00130 00027 ! check_entry,insert_entry into tables
C00136 00028 ! expression evaluation routines
C00150 00029 ! P_EXP2_BASIC, OPCODE, ERROR HANDLER
C00156 00030 ! exp,bfact,bterm,aexp,term,factor
C00170 00031 ! exp2 starts here, p_exp_basic
C00171 00032
C00176 00033 ! relation,scalar_relational,mk_condition,deproach_proc
C00182 00034 ! force_frame_proc,ft_proc
C00187 00035 ! stiffness_cond
C00192 00036 ! get_condition begins here
C00197 00037 ! P_clauses, T_gen
C00208 00038 ! P_statement, F_state, modify_continue, modify_flush
C00213 00039 ! begin_P,end_P, open_paren_P
C00223 00040 ! for_P,case_P,do_P
C00230 00041 ! retry_p,move_P,affix_P,unfix_P
C00237 00042 ! signal_p, wait_p
C00242 00043 ! dump_P
C00246 00044 ! on_P, reference_P,deproach_P
C00250 00045 ! open_P,center_P,stop_P,enable_P,disable_P
C00255 00046 ! require_P
C00261 00047 ! operate_p
C00264 00048 ! dimension_P
C00267 00049 ! string_P
C00269 00050 ! abort_P, note_P,comment_P,speed_factor_P,wrist_P,setbase_P
C00273 00051 ! define_P,declare_P,global_P,procedure_P,return_P
C00290 00052 ! P_statement execution starts here
C00302 00053 ! execution starts here, initialization
C00307 00054 ! set up input and output
C00311 00055 ! set up predefined dimensions, constants, macros and variables
C00314 00056 ! PARSE PROGRAM
C00316 00057 ! SWAP TO AL COMPILER
C00318 ENDMK
C⊗;
COMMENT UPDATES TO PARSE BY MSM
2- 7-80 event array element in cmon now accepted
10-20-78 indexed frames and events now accepted
10-10-78 f←⊗ + xhat now invalid
9- 8-78 FIXED BUG OF identifier not used when it is actually used in
argument field of procedure
fixed bug of s←1.75 being parsed to s←1.0 because of the way
←← was handled.
8- 4-78 no more I option on error
unused variables now give warning message
7-26-78 no more user comment delimiters and macro delimiters
7-13-78 WRIST,SETFORCE
6-27-78 INT DIV MOD ETC
6- 3-78 IMPLEMENTED ARRAY, PROCEDURE DECLARATIONS AND RELEVANT UPDATE TO
EXP,BFACT, case statement
DO .... UNTIL STATEMENT
5-30-78 IMPLEMENTED DEPROACH(F)←T
5-29-78 IMPLEMENTED LOG,EXP,CONSTRUCT,≡
CASE STATEMENT
5 -15-78 FIXED BUG IN CHECK_DIMENSIONS WHICH CAUSED A RECORD WITH
ALL COEFFICIENTS NON ZERO TO BE NOT TREATED AS NIL_DIMENS
COMPILER SWITCH "N" AND UNKNOWN SWITCH PASSED THROUGH AT ARG'S REQUEST
3 - 7-78 UNIQUE S-EXPRESSION IDENTIFIERS BEGINNING WITH $
3 - 4-78 EXPRESSION PARSER CHANGED, ADDED SIN, COS, ACOS, ASIN, etc
11-24-77 NONRIGIDLY DEFAULT AFFIXMENT CHANGED TO RIGIDLY
NO NULL ADDED
9-15-77 FIXED BUG THAT MAKES INV(A)*B TO (TINVRT (TTMUL A B))
BY ADDING "INV" TO PARSE_SPECIAL
6-29-77 GLOBAL BACKUP TO END OF LATEST END,BEGIN OR SEMI-COLON POSSIBLE
6- 7-77 PREDEFINED MACROS
ADJACENT MACRO BUG FIXED
6- 1-77 CODE FOR NEW FORCE STUFF
5-19-77 UNARY + AND - FINALLY WORK, SIGH
5- 3-77 STRICT DIMENSIONAL CHECKING NOW DEFAULT
3-16-77 ENABLE/DISABLE
MESSAGE END OF EACH BLOCK GIVING LIST OF VARIABLES NOT DEFINED AND
NOT USED
REMOVED PARSESHIT
1- 9-77 MORE MEANINGFUL ERROR MESSAGES
1- 9-77 CAN CORRECT MORE ERRORS
WILL NOT ACCEPT DIMENSIONS ON ANYTHING EXCEPT SCALARS AND VECTORS.
1- 5-77 ACCEPTS STRING DEFINITIONS
12-25-76 CAN CORRECT MINOR ERRORS IN SOURCE CODE IN_LINE
12-23-76 CAN ACCEPT TTY INPUT AS A FILE
12-21-76 ACCEPTS DIMENSIONS ON CONDITION MONITORS
CREATES NEW DECLARATIONS IF UNDECLARED TERM USED IN LHS OF ASSIGNMENT
12-15-76 BAIL CAN BE CALLED IN FROM REQUIRE SWITCHES INSTRUCTIONS
DEFAULT AND ONLY ACCEPTABLE DIMENSIONS OF FRAME IS DISTANCE
TRANS SHOULD BE DIMENSIONLESS
12-14-76 NEW SETUP FOR RESERVED WORD DEFINITIONS, ETC.
ERROR RECOVERY 55, WHEN FILE ASKED FOR DOES NOT EXIST
COMBINATION OF PLUS_R,MINUS_R
COMBINATION OF TMAKE_R, FMAKE_R
12-10-76 WHEN ERROR OF MACRO WITH PARAMETERS ACTUAL PARAMETERS SUBSTITUTED
ACCEPTS ONLY DISTANCE VECTOR ETC NO LONGER VECTOR DISTANCE
REQUIRE BAIL ADDED
12- 7-76 MACRO EXPANSION OF TEXT OK
12- 6-76 REQUIRE COMMENT_DELIMITERS
11-16-76 NEW CHECK_ENTRY AND INSERT_ENTRY PROCEDURES
11-15-76 INSERTION OF STRICT_DIMEN_CHECK SWITCH
ALL PREDEFINED CONSTANTS DECLARED DIMENSIONLESS
11-14-76 DIMENSIONLESS DECLARATION COERCED TO TYPE OF EXPRESSION
XHAT,YHAT,ZHAT MADE DIMENSIONLESS
11-6-76 NEW WAY OF COMPUTING DIMENSIONS
11-2-76 CHANGE LABEL TO STMLAB ON PG 6
11-2-76 CHANGES TO DECLARE_P TO allow default of distance to frames
11-2-76 LN49 PG 24 ADDED TO GIVE DIMENSION OF FRAME AS DISTANCE
11-2-76 ADDED ELSE DIM←0 AFTER SECOND IF STATEMENT TO CURE BUG ON PG 41 DECLARE_P
11-1-76 WOBBLE COMMAND IMPLEMENTED
10-29-76 LOGGING FEATURE IMPLEMENTED
10-27-76 TVSUB AND VSUB IMPLEMENTED
10-18-76 CHANGE STOP BLUE OR YELLOW TO STOP BARM OR YARM;
comment the AL to S-expression translator AND MSM SWITCHES;
Begin "PARSE"
REQUIRE "
COMPILE WITH (/R) SWITCH OTHERWISE IT WILL DIE
" MESSAGE;
REQUIRE 4096 STRING_PDL; REQUIRE 4096 STRING_SPACE; REQUIRE 2048 SYSTEM_PDL;
require "[][]" delimiters;
define
α =[begin],
β =[end],
! =[comment],
tab ='11,
alt ='175,
lf ='12,
ff ='14,
cr ='15,
space ='40,
dquote ='42,
squote ='47,
rubout ='177,
crlf =[('15&'12)],
ampersand ='46,
id_hasher =32,
array_hasher =16,
procedure_hasher=16,
macro_hasher =16,
metric_hasher =16,
reserved_hasher =256,
RPTR =[RECORD_POINTER],
RCLASS =[RECORD_CLASS],
RANY =[RECORD_POINTER(ANY_CLASS)],
preload_array(name, defs, type, first, len)=[
preset_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
! if /nB is set in the command line then assume he wants a debugging parser;
define id_type_table=0,
macro_type_table = 1,
macro_in_macro_type_table = 2,
dimension_type_table = 3 ,
array_type_table = 4,
procedure_type_table = 5;
require "<><>" delimiters;
ifc ¬declaration(debug_compile) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), space, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define debug_compile=false;
elsec define debug_compile=true;
endc
endc
define
decipher_compiletime(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+6 for 21];
"a">;
require unstack_delimiters;
require ifc ¬debug_compile
thenc " NON-" elsec " " endc & "DEBUGGING VERSION " message;
ifc debug_compile thenc EXTERNAL PROCEDURE BAIL;
REQUIRE "LA" ERROR_MODES; ! to compile and go home when system busy;
endc
define
indices(name, postfix)=[
redefine xxcount=0;
redefine xx(xxarg)=[
redefine xxtemp=[define xxarg] & [postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name];
! ID postfix conventions
_VALUE AL data types
_RES reserved word types
_beg reserved word group begin
_end reserved word group end
_R REDUCE action routines
_P PARSE action routines
_TOKEN scanner token types
_CM condition monitors
_X indices of various sorts
_METRIC dimensional analysis non-sense
_DIMEN how to combine various matrix operands
_TYPE to decide which table to insert into
;
! **********; require "SNAILR[AL,HE]" source_file; ! **********;
INTEGER PROCEDURE ___TIME;
BEGIN
INTEGER __T;
quick_code
setz '13, ;
calli '13,'27 ;
movem '13,__T ;
end;
RETURN(__T);
END;
! ************ MSM SWITCHES *************;
DEFINE DEFIN_PRINT_SWITCH = FALSE;
DEFINE DUP_FILE = true;
DEFINE full_set = true;
! statement, operator, sex, require, move definitions;
redefine xx(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine xx_temp="define " & "str" & "_RES=reserved_X_count";
xx_temp;];
redefine yy(str,str2)=[];
redefine zz(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine zz_temp="define " & "str" & "_RES=reserved_X_count";
zz_temp;];
define statement_definitions=[
xx(BEGIN)
yy(COBEGIN)
xx(END)
yy(COEND)
yy([;])
zz(OPEN_PAREN)
yy([(])
zz(DECLARE)
yy(SCALAR, scalar_value)
yy(VECTOR, vector_value)
yy(ROT, rot_value)
yy(FRAME, frame_value)
yy(PLANE, plane_value)
yy(TRANS, trans_value)
yy(EVENT, event_value)
yy(ATOM, atom_value)
yy(WORLD, world_value)
yy(LABEL, label_value)
! xx(GLOBAL) ;
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(DO)
xx(CASE)
xx(RETURN)
xx(MOVE)
xx(OPERATE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
! xx(WHEN) ;
xx(DUMP)
! xx(ASSERT)
yy(DENY) ;
xx(ON)
yy(DEFER)
! xx(REFERENCE) ;
xx(OPEN)
yy(CLOSE)
xx(CENTER)
xx(STOP)
xx(SPEED_FACTOR)
xx(DEPROACH)
xx(PROCEDURE)
xx(RETRY)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
! xx(STRING)
yy(NEW_STRING)
yy(OLD_STRING) ;
xx(COMMENT)
xx(ABORT)
yy(PRINT)
yy(PAUSE)
yy(PROMPT)
xx(NOTE)
yy(NOTE1)
yy(NOTE2)
xx(SETBASE)
xx(WRIST)
xx(ENABLE)
xx(DISABLE)
];
define operator_classes=[
zz(COMMA)
yy([,])
xx(EQV, eqv_x)
yy([≡], eqv_X)
xx(OR, or_X)
yy([∨], or_X)
yy([⊗], xor_X)
yy(XOR, xor_X)
xx(AND, and_X)
yy([∧], and_X)
xx(NOT, not_X)
yy([¬], not_X)
zz(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
zz(ABS)
yy([|], sabs_X)
! yy(VVVTRANS);
zz(ADD)
yy([+], plus_X)
yy([-], minus_X)
zz(MULT)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy(MAX, max_x)
yy(MIN, min_x)
yy(DIV, div_x)
yy(MOD, mod_X)
! yy(VVROT, vvrot_X) ;
zz(WRT)
yy(WRT, wrt_X)
yy(→, →_X)
yy([↑], stos_X)
zz(FUNC)
! yy([#],, nomv_X);
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
yy(INT, int_X)
yy(CONSTRUCT, construct_X)
yy(SQRT, sqrt_x)
yy(SIN, sin_x)
yy(COS, cos_x)
yy(TAN, tan_x)
yy(ASIN, asin_x)
yy(ACOS, acos_x)
yy(ATAN2, atan2_x)
yy(LOG, log_x)
yy(EXP, exp_X)
yy(RUNTIME, runtime_x)
! zz(SCALAR)
yy(ANGLE, angle_X);
zz(CLOSE_PAREN)
yy([)])
];
define require_definitions=[
xx(SOURCE_FILE)
xx(MESSAGE)
xx(ERROR_MODES)
xx(COMPILER_SWITCHES)
xx(BAIL)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(APPROACH)
! yy(ARRIVAL) ;
yy(DEPARTURE)
xx(TO)
xx(WOBBLE)
xx(NO_NULLING)
xx(RTMOVE)
xx(NULLING)
xx(DIRECTLY)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
sex_RES =-2,
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
! brace, condition_monitor, dimension, misc reserved word definitions;
define brace_definitions=[
zz(BRACE)
yy([}])
yy([{])
];
define cm_definitions=[
zz(cm)
qq(nil)
yy(FORCE, force_cm)
yy(TORQUE, torque_cm)
yy(DURATION, duration_cm)
yy(TURN, turn_cm)
yy(TEMPERATURE)
yy(SQUEEZE)
];
define metric_definitions=[
zz(METRIC)
qq(nil)
yy(DISTANCE, distance_METRIC)
yy(TIME, time_METRIC)
! yy(MASS, mass_METRIC) ;
yy(ANGLE, angle_METRIC)
yy(FORCE, force_METRIC)
];
DEFINE MISC_DEFINITIONS=[
zz(MISC)
yy([?])
yy(ABS)
! yy(TO);
yy(TRACING)
yy(WHERE)
yy(THEN)
yy(FORM)
yy(AT)
yy(BY)
yy(CHANGING)
yy(ALSO)
yy(DONT)
yy(ONLY)
yy(QUERY)
yy(RIGIDLY)
yy(NONRIGIDLY)
yy(STEP)
yy(INSCALAR)
yy(UNTIL)
yy(ELSE)
! yy(⊗) ;
];
redefine zz(str)=[];
redefine qq(str)=[
redefine qq_temp=[xx(str)];
qq_temp;];
redefine yy(str,str2)=[
redefine yy_temp=[xx(str)];
yy_temp;];
indices(metric_definitions, _METRIC);
define
metric_max =xxcount-1;
indices(cm_definitions, _CM);
EVALdefine basic_dimensions=[
redefine zz(str,str2)=[];
redefine qq(str,str2)=[];
redefine yy(str,str2)=[xx(str)];
metric_definitions
];
! dec_name, declaration names for input and output;
! don't juggle the order of these definitions, because the parse will cease to
function;
define dec_name_definitions=[
xx(SCALAR, $SVAR)
xx(VECTOR, $VVAR)
xx(ROT, $RVAR)
xx(FRAME, $FVAR)
xx(PLANE, $PVAR)
xx(TRANS, $TVAR)
xx(EVENT, $EVAR)
xx(ATOM, $ATOM)
xx(WORLD, $WVAR)
! xx(CM_LABEL, $OMNLAB)
xx(CLC_LABEL, $CLCLAB)
xx(CH_LABEL, $CHGLAB)
xx(LABEL, $STMLAB) ;
xx(LABEL, $LAB)
];
! data types;
DEFINE
string_VALUE =-2,
form_VALUE =-1,
boole_VALUE =0; ! others follow directly, but see later;
define
dec_name_count=0;
redefine xx(in, out)=[
redefine dec_name_count=dec_name_count+1;
redefine xx_temp="define in" & "_VALUE=" & cvms(dec_name_count);
xx_temp;];
dec_name_definitions;
redefine boole_value=scalar_value;
define frame_exp_VALUE=trans_VALUE; ! COERCION DICTATES THAT THESE BE THE SAME;
redefine xx(in, out)=["out",];
preload_array(
dec_name, dec_name_definitions, string, 1, dec_name_count);
! operators;
define operator_definitions=[
XX(NOT)
XX(EQV)
XX(AND)
XX(OR)
XX(XOR)
XX(SEQ)
XX(SNE)
XX(SGT)
XX(SLT)
XX(SGE)
XX(SLE)
XX(UVECT)
XX(AXIS)
XX(POS)
XX(ORIENT)
XX(TMAKE)
XX(VMAKE)
XX(FMAKE)
XX(VVTRANS)
! XX(SNEG) ;
XX(RINV)
XX(SABS)
XX([+], PLUS)
XX([-], MINUS)
XX([*], TIMES)
XX(MAX)
XX(MIN)
XX(DIV)
XX(MOD)
XX(INT)
XX(WRT)
XX(ROT)
XX(→)
! XX(ANGLE);
XX(VDOT)
XX(VCROSS)
XX(CONSTRUCT)
XX(SQRT)
XX(SIN)
XX(COS)
XX(TAN)
XX(ASIN)
XX(ACOS)
XX(ATAN2)
XX(LOG)
XX(EXP)
XX(RUNTIME)
XX(VVROT)
XX(SDIV)
XX(STOS)
XX([(], LPAREN)
XX(NOMV)
];
define
op_count=0;
redefine xx(str1, str2)=[
redefine op_count=op_count+1;
ifc "str2"=null
thenc redefine xxtemp=[define str1] & "_X=op_count";
elsec redefine xxtemp=[define str2] & "_X=op_count";
endc
xxtemp;];
operator_definitions;
redefine xx(str1,str2) = [ "str1", ];
preload_array(OPERATORS, OPERATOR_DEFINITIONS, STRING, 1, OP_COUNT);
! reserved_words;
define reserved_definitions=[
brace_definitions
cm_definitions
statement_definitions
operator_classes
require_definitions
move_definitions
misc_definitions
];
define
reserved_count=0;
redefine zz(name)= [];
redefine qq(name)= [];
redefine xx(name)=[
redefine reserved_count=reserved_count+1;];
redefine yy(name, special)=[
redefine reserved_count=reserved_count+1;];
reserved_definitions;
redefine xx(name)=["name",];
redefine yy(name,special)=["name",];
preload_array(
reserved_words, reserved_definitions, string, 1, reserved_count);
redefine zz(name)=[
redefine class=["name"];
];
redefine xx(name)=[
redefine xxtemp=[name] & "_RES";
redefine class=["name"];
xxtemp,];
redefine yy(name,special)=[
redefine yytemp= class &"_RES";
yytemp,];
preload_array(
reserved_class, reserved_definitions, integer, 1, reserved_count);
redefine xx(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
redefine yy(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
preload_array(
reserved_special, reserved_definitions, integer, 1, reserved_count);
whilec [reserved_count > 9*reserved_hasher/10] doc
[require "
RESERVED TABLE NOT BIG ENOUGH, WILL DOUBLE IT.
" message ;
redefine reserved_hasher=reserved_hasher+reserved_hasher;]
endc
string array
reserved[0:reserved_hasher-1];
integer array
com_type[0:reserved_hasher-1];
! init_reserved;
forward SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
procedure init_reserved;
α string s; integer i, k;
boolean procedure find_sym(string s; reference integer k);
α string probe;
k ← hash(s, reserved_hasher);
while (probe ← reserved[k])≠null do
if equ(s, probe) then return(true) else k ← (k+1) mod reserved_hasher;
return(false);
β;
arrclr(reserved); arrclr(com_type);
for i ← 1 step 1 until reserved_count do
if find_sym(reserved_words[i], k)
then α if reserved_class[i] ≠ SEX_RES then
outstr(reserved_words[i] & " doubly defined!" & crlf);
β
else
α
reserved[k] ← reserved_words[i];
com_type[k] ← reserved_class[i]+reserved_special[i]*reserved_hasher;
β;
require "<><>" delimiters;
s ← decipher_compiletime();
require unstack_delimiters;
outstr("COMPILED "&s&crlf&crlf);
β;
require init_reserved initialization [0];
! predefined constants;
define constant_definitions=[
XX(GARB_ID, scalar, nil) ! do not move this entry;
XX(PI, scalar, nil)
XX(π, scalar,nil)
XX(INCH, scalar, distance)
XX(INCHES, scalar, distance)
XX(CM, scalar, distance)
XX(SEC, scalar, time)
XX(SECONDS, scalar, time)
XX(DEG, scalar, angle)
XX(DEGREES, scalar, angle)
XX(RADIANS, scalar, angle)
XX(GM, scalar, force)
XX(OZ, scalar, force)
XX(LBS, scalar, force)
XX(OUNCES, scalar, force)
XX(BARM_ERROR, scalar, nil)
XX(YARM_ERROR, scalar, nil)
XX(BHAND_ERROR, scalar, nil)
XX(YHAND_ERROR, scalar, nil)
XX(VISE_ERROR, scalar, nil)
XX(DRIVER_ERROR,scalar, nil)
! XX(RPM, scalar, angular_velocity);
XX(XHAT, vector, nil)
XX(YHAT, vector, nil)
XX(ZHAT, vector, nil)
XX(NILVECT, vector, nil)
XX(NILROTN, rot, angle)
XX(NILTRANS, trans, distance)
XX(STATION, trans, distance)
XX(YPARK, trans, distance)
XX(BPARK, trans, distance)
XX(YARM, trans, distance)
XX(BARM, trans, distance)
XX(FIXED_JAW, trans, distance)
XX(MOVING_JAW, trans, distance)
XX(DRIVER_GRASP,trans, distance)
XX(DRIVER_TIP, trans, distance)
XX(YHAND, scalar, distance)
XX(BHAND, scalar, distance)
XX(VISE, scalar, distance)
XX(DRIVER_TURNS,scalar, nil)
XX(ARRIVAL, event, nil)
XX(TRUE, boole, nil)
XX(FALSE, boole, nil)
XX(CRLF, string, nil)
];
define
const_count = 0;
redefine xx(str, i1, i2)=[redefine const_count = const_count+1;];
constant_definitions;
define zap_const(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str, i1, i2)=[arg,];
elsec redefine xx(str, i1, i2)=[arg] & [postfix,];
endc
preload_array(name, constant_definitions, type, 1, const_count)];
zap_const(
preconst, string, "str");
zap_const(
preconst_type, integer, i1, _VALUE);
zap_const(
pre_dimens, integer, i2, _METRIC);
! predefined macros;
define macro_definitions=[
! XX(DIRECTLY, [ WITH APPROACH = NILDEPROACH WITH DEPARTURE = NILDEPROACH]);
XX(CAUTIOUS, [ SPEED_FACTOR ← 4.0])
XX(SLOW, [ SPEED_FACTOR ← 6.0])
XX(QUICK, [ SPEED_FACTOR ← 1.0])
XX(QUICKLY, [ WITH SPEED_FACTOR = 1.0])
XX(NORMALLY, [ WITH SPEED_FACTOR = 2.0])
XX(CAUTIOUSLY, [ WITH SPEED_FACTOR = 4.0])
XX(SLOWLY, [ WITH SPEED_FACTOR = 3.0])
XX(SECOND, [ SECONDS ])
XX(DEGREE, [ DEGREES ])
XX(RADIAN, [ RADIANS ])
XX(RAD, [ RADIANS ])
XX(RPM, [ (6*DEGREES/SECOND)])
XX(LB, [ LBS ])
XX(OUNCE, [ OUNCES ])
XX(NILVEC, [ NILVECT ])
XX(NILVECTOR, [ NILVECT ])
XX(NILROT, [ NILROTN ])
XX(SETUP_BARMF, [ FRAME BARMF;
AFFIX BARMF TO BARM AT TRANS(ROT(XHAT,180*DEGREES),NILVECT*inches) RIGIDLY; ])
XX(SETUP_BGRASP, [ FRAME BGRASP;
AFFIX BGRASP TO BARM AT TRANS(ROT(XHAT,180*DEGREES),NILVECT*inches) RIGIDLY; ])
XX(INITIALIZE, [ MOVE BARM TO BPARK WITH DURATION = 3*SECONDS;
OPEN BHAND TO 3.0*INCHES; ])
XX(NO_NULL, [ NO_NULLING ])
XX(APPROXIMATELY, [ WITH NO_NULLING ])
XX(PRECISELY, [ WITH NULLING ])
XX(CLOCKWISE, [ ($CW + )])
XX(COUNTERCLOCKWISE, [ ($CW -)])
XX(CW, [($CW +)])
XX(CCW, [($CW -)])
XX(GENTLY, [ WITH STOP_WAIT_TIME=0*SECONDS])
XX(TIGHTLY, [ WITH STOP_WAIT_TIME=0.5*SECONDS])
XX(PANIC_BUTTON,[ 1024]) ! = '2000 ;
XX(EXCESSIVE_FORCE,[ 2048]) ! ='4000 ;
XX(TIME_OUT, [ 4096 ]) ! ='10000 ;
XX(DEPARTING, [ DURATION ≥ 0.5*SECONDS ])
];
! compiler switches and control tables;
! As the AL compile time system runs, several intermediate files are created
and destroyed. The default extensions of these files are listed below.
.AL user the ALGOL like AL source language
.LOG user file of errors detected by the PARSER
.SEX AL s-expression version of AL source code
.ALP (.AL0) ALC pseudo code
.ALT (.AL1) ALC trajectory file
.ALV (.AL2) ALC constants and variable definitions for pseudo code
.ALS (.AL3) ALC symbol table usable by the PDP-11 runtime system
.ALL ALC hybrid s-expression/real AL listing
.LST PALX PDP-11 assembly code listing
.BIN PALX PDP-11 binary file loaded by 11TTY
.DMP 11TTY PDP-11 core image
;
! compiler switches;
define compiler_switches=[
xx(K, false) ! keep extraneous intermediate files: .ALP, .ALV, .ALT;
xx(I, false) ! inhibit the deletion of the .SEX file;
xx(S, false) ! inhibit the deletion of the .ALS file;
xx(X, false) ! extra switch for new trial compilations?;
xx(L, false) ! generate a PALX assembly listing;
xx(N, false) ! swap to ALCNEW instead of ALC;
xx(B, false) ! run BAIL immediately after scanning the command line;
xx(E, false) ! load the .BIN file into the PDP-11;
];
indices(compiler_switches, _X);
define
switch_max =xxcount-1;
redefine xx(name, default)=["name",]; preload_array(
switch_name, compiler_switches, string, 0, switch_max+1);
redefine xx(name, default)=[default,]; preload_array(
switch_default, compiler_switches, boolean, 0, switch_max+1);
boolean array
switch_setting[0:switch_max];
procedure preset_switches;
α integer i;
for i ← 0 step 1 until switch_max do switch_setting[i] ← switch_default[i];
β;
require preset_switches initialization[0];
! hash, declaration of debugging variables, start of hidden_parse;
SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
α INTEGER I,TOT,C;
C←I←1; TOT←0;
WHILE I≠0 DO TOT←TOT+(C←C+1)*(I←LOP(S));
RETURN(TOT MOD MAX);
β;
ifc debug_compile thenc ! some variables that can be used for debugging;
require "BREAK.HDR[1,PJ]" source_file;
RPTR(any_class)
__r0, __r1, __r2, __r3, __r4, __r5, __r6, __r7, __r8, __r9;
string
__s0, __s1, __s2, __s3, __s4, __s5, __s6, __s7, __s8, __s9;
integer
__i0, __i1, __i2, __i3, __i4, __i5, __i6, __i7, __i8, __i9;
real
__x0, __x1, __x2, __x3, __x4, __x5, __x6, __x7, __x8, __x9;
procedure debug_init;
α
__r0 ← __r1 ← __r2 ← __r3 ← __r4 ← __r5 ← __r6 ← __r7 ← __r8 ← __r9 ← null_record;
__s0 ← __s1 ← __s2 ← __s3 ← __s4 ← __s5 ← __s6 ← __s7 ← __s8 ← __s9 ← null;
__i0 ← __i1 ← __i2 ← __i3 ← __i4 ← __i5 ← __i6 ← __i7 ← __i8 ← __i9 ← 0;
__x0 ← __x1 ← __x2 ← __x3 ← __x4 ← __x5 ← __x6 ← __x7 ← __x8 ← __x9 ← 0.0;
β;
require debug_init initialization[0];
endc
! The following (making all of parse a recursive procedure) is a hack to get the
restart option to work properly. As soon as a better way is found of
making sure everything gets reinitialized properly, this should be taken
out;
IFC FALSE THENC
recursive procedure hidden_parse;
α "hidden_parse"
ENDC;
! ---- DECLARATIONS ----;
external integer
rpgsw;
RPTR(file)
AL_file, ! AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file, ! ALC listing file;
LOG_file, ! LOG listing file;
NEW_file,
PRESENT_file; ! Present file;
BOOLEAN
DISK, ! TRUE IF INPUT IS COMING FROM DISK;
AUTO_PROCEED, ! TRUE IF AUTO_PROCEED SWITCH IS ON FOR ERROR RECOVERY;
IGNORE_CORRECTION, ! TRUE IF DONT WANT TO MODIFY BUT JUST CONTINUE;
LOGGING, ! TRUE IF LOGGING WANTED;
COMPILE_LOGGING, ! TRUE IF LOGGING WANTED THROUGH REQUIRE STATEMENT;
now_top_file,
LOG_FILE_OPEN,
STRICT_DIMEN_CHECK;
ifc dup_file thenc
BOOLEAN
WANT_DUP_FILE; ! TRUE IF WANT CORRRECTED FILE;
endc
STRING
cmd_line,
INFILE,
OUTFILE, ! INPUT,OUTPUT & LOG FILES;
NEWFILE,
LOGFILE;
INTEGER
CHANIN,
CHANOUT,
CHANNEW,
CHANTTYO,
CHANLOG;
STRING
OUTSTRING,
PARSED_STRING,
INSTRING, ! INPUT STRING;
TABLE1; ! BREAK TABLES;
! GET_TOKEN VARIABLES;
REAL
REALNUM;
INTEGER
TYPE_OF_RES_WORD, ! TYPE PULLED OFF OF COM_TYPE;
SPECIAL_INFO, ! INFO PASSED FROM SCANNER TO PARSER - DEPENDS ON TYPE;
ID_TYPE,
ARRAY_TYPE,
PROCEDURE_TYPE,
BLOCK_LEVEL_OF_DEFN,
RESERVED_TOKEN_PTR,
TYPE_OF_TOKEN;
define
special_token =-1,
undeclared_token=0,
id_token =1,
numeric_token =2,
string_token =3,
macro_token =4,
MACRO_BODY_TOKEN=5,
metric_token =6,
reserved_token =7,
array_token =8,
procedure_token =9;
STRING PROCEDURE TOKEN_TYPE_TRANSFORM;
α string s1;
s1← CASE TYPE_OF_TOKEN OF ( "undeclared","id","numeric",
"string","macro","macro_body","metric","reserved","array","procedure");
return(s1&"_type");
β;
STRING PROCEDURE ID_TYPE_TRANSFORM;
α string s1;
s1← CASE (ID_TYPE + 2 )OF ("string","form","boole","scalar",
"vector","rot","frame","plane","trans","event","atom",
"world","on_label","calculator_label",
"changer_label","statement_label");
return(s1&"_type");
β;
STRING
TOKEN,TOKEN2,
TOKEN_FRONT;
RPTR(ANY_CLASS)
TOKEN_PTR;
! END GET_TOKEN VARIABLES;
integer
word_R_break, ! break tables;
non_blank_break,
word_S_break,
close_brace_break,
non_digit_break,
quote_break,
macro_delimiter_break,
semicolon_A_break,
cr_break,
paren_cr_break,
lf_ff_break,
semicolon_R_break,
knvrt_break,
omit_break,
tty_input_break;
STRING
CURRENT_FRAME; ! TOKEN OF THE CURRENT FRAME - DEFAULT SET TO "YARM";
INTEGER
SPACING, ! SPACING FOR OUTPUT;
SAVSPACING;
BOOLEAN
REJECT, ! TRUE WHEN THE LAST TOKEN IS REJECTED BY THE CALLING PROC;
switch_file,END_FLAG;
INTEGER
DEC_NUM, ! THE NUMBER OF DECLARATIONS IN THE CURRENT BLOCK;
ARRAY_DEC_NUM,
PROCEDURE_DEC_NUM,
MACRO_DEC_NUM, ! THE NUMBER OF MACROS IN CURRENT BLOCK;
DIMEN_DEC_NUM; ! THE NUMBER OF DIMENSIONS IN THE CURRENT BLOCK;
STRING
OUTEXPR; ! FOR THE CONSTRUCTION OF THE STRING FOR EXPRESSIONS;
STRING
OPEN_BRACE;
INTEGER
CHECK_TYPE_VAR; ! RETURNS TYPE OF ID FROM CHECK_ENTRY;
STRING
MACRO_STRING;
! ERROR VARIABLES;
BOOLEAN
INSIDE_MACRO_DEFINITION,
INSIDE_DECLARE_P,
INSIDE_CONDITION_MONITOR,
INSIDE_STRING_DECLARATION,
INITIALIZE, ! INITIALIZATION PROCESS;
GLOBAL_BACKUP,
patch_code,
GLOBAL_MODIFIED,
PROMPT_FOR_MODIFIABLE_ERROR_ONLY;
INTEGER
NUM_OF_ERRORS,
INSIDE_STATEMENT,
NUM_OF_ERRORS_FLUSHED,
NUM_OF_ERRORS_MODIFIED;
! END ERROR VARIABLES;
INTEGER
RUNTIME;
STRING
CURRENT_DEVICE;
! record declarations;
RCLASS
PARAM_LIST(
STRING
ID,
USER_ID;
RPTR(PARAM_LIST)
NEXT
);
RCLASS
MACRO_LIST(
STRING
VALUE, ! ACTUAL MACRO body;
ID;
INTEGER
NUM; ! NUMBER OF PARAMETERS;
RPTR(MACRO_LIST)
NEXT, ! POINTS TO NEXT MACRO WHICH HASHES TO THE SAME ENTRY;
LAST, ! BACK POINTER IN THE SAME LIST;
LINK; ! USED ONLY FOR PARAMETER EXPANSION, POINTS TO THE
PARAMETER DEFINED JUST BEFORE THIS ONE;
RPTR(PARAM_LIST)
PARAMS;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(MACRO_LIST)
TOP_PARAM,
current_macro,
TOP_MACRO,
CUR_MACRO;
RPTR(MACRO_LIST) ARRAY
MACRO_TABLE[0:macro_hasher];
RCLASS
MACRO_STACK(
RPTR(MACRO_LIST)
LIST_PTR;
RPTR(MACRO_STACK)
STACK_LINK
);
RPTR(MACRO_STACK)
MACRO_STACK_TOP,
MACRO_ST2;
RCLASS
DIMENS_EXPONENT(
STRING
NAME;
INTEGER
DISTANCE,
TIME, ! GIVES EXPONENTS OF VARIOUS COEFFICIENTS;
MASS,
ANGLE,
FORCE;
RPTR(DIMENS_EXPONENT)
NEXT,
LAST;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(DIMENS_EXPONENT)
NIL_DIMENS,
DISTANCE_DIMENS,
TIME_DIMENS,
! MASS_DIMENS;
ANGLE_DIMENS,
FORCE_DIMENS,
TORQUE_DIMENS,
VELOCITY_DIMENS,
ANGULAR_VELOCITY_DIMENS,
TOP_DIMENS, ! POINTS TO TOP MACRO IN THIS BLOCK;
EXP_DIMENS;
RPTR(DIMENS_EXPONENT) ARRAY
DIMENS_TABLE[0:metric_hasher],
D_TABLE[0:metric_max];
RCLASS
ID_LIST(
STRING
NAME,
BODY;
INTEGER
FLAGS,
TYPE;
RPTR(ID_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(ID_LIST) ARRAY
SYMBOL_TABLE[0:id_hasher];
RPTR(ID_LIST)
TOP_ID;
RCLASS
array_LIST(
STRING
NAME;
INTEGER
FLAGS,
#DIMENS,
TYPE;
RPTR(array_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(array_LIST) ARRAY
ARRAY_SYMBOL_TABLE[0:array_hasher];
RPTR(array_LIST)
TOP_array;
RCLASS
procedure_LIST(
STRING
NAME;
INTEGER
FLAGS,
#ARGS,
TYPE;
RPTR(PROCEDURE_LIST)
NEXT, ! POINTS TO NEXT PROCEDURE WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE PROCEDURE DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
RPTR(id_list,array_list) ARRAY
ARGS;
INTEGER ARRAY
isid,ARGMODE;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(procedure_LIST) ARRAY
procedure_SYMBOL_TABLE[0:procedure_hasher];
RPTR(procedure_LIST)
TOP_procedure;
RCLASS
SOURCE_LIST(
INTEGER
CHAN, ! i/o CHANNEL NUMBER OF input, -1 if from macro;
NUM, ! NUMBER OF PARAMETERS IN THE CURRENT MACRO;
PN,
LN; ! PAGE AND LINE NUMBER OF THE PUSHED FILE;
STRING
CUR_STRING, ! curline WHEN PUSHED;
CUR_STRINGR, ! curliner WHEN PUSHED;
FILE_NAME, ! NAME OF THE INPUT FILE WHEN PUSHED;
P_STRING,
MACRO_STRING;
RPTR(SOURCE_LIST)
NEXT;
RPTR(MACRO_STACK)
MACRO_STACK_TOP;
RPTR(MACRO_LIST)
CUR_MACRO;
RPTR(FILE)
COPY_FILE,
FILE_PTR;
INTEGER
CHANTTYO,
CHANNEW
);
RPTR(SOURCE_LIST)
TOP_SOURCE;
! other declarations;
INTEGER
EXP_TYPE; ! TYPE OF EXPRESSION FOUND BY P_EXP;
BOOLEAN
PLAN_STATEMENT; ! TRUE IF CURRENT STATMENT IS PREFIXED BY PLAN;
STRING
CHANGER_HEAD; ! NON NULL IF PARSING A STATEMENT INSDIDE A CHANGER;
INTEGER
T_COUNT, ! COUNTER FOR PRODUCING UNIQUE ID'S;
S_COUNT; ! COUNTER FOR PRODUCING UNIQUE SCALARS;
BOOLEAN
NO_OP_SO_FAR,
OP_EXPECTED; ! TRUE WHEN P_EXP EXPECTS AN OPERATION;
INTEGER
DELIMITER_1,
DELIMITER_2; ! HEAD AND TAIL DELIMITER OF macro bodies;
INTEGER
MAC_NUM; ! NUMBER OF PARAMS IN THE CURRENT MACRO EXPANSION;
INTEGER
BLOCK_LEVEL;
! GARBAGE DECLARATIONS (VERY LOCAL);
BOOLEAN
T,
EOF;
INTEGER
COUNT,
I,
N,
BRCHAR;
STRING
GARB;
INTEGER
LINENUM,
PAGENUM,
SOSNUM,
typed_page_num, ! on tty;
sourcelvl;
STRING
CURLINER,
CURLINE;
! error, error_recovery, error_reject, print, file_indent;
FORWARD RECURSIVE PROCEDURE P_STATEMENT;
FORWARD RECURSIVE PROCEDURE GET_TOKEN(boolean noexpand(false));
FORWARD PROCEDURE OPEN_LOGGING_FILE;
forward RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
forward RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S;
INTEGER TABLE_TYPE; RPTR(ANY_CLASS) RR1(NULL_RECORD));
forward boolean procedure got_output(RPTR(file) F; string ext(null));
RPTR(ANY_CLASS) PROCEDURE ERROR_basic(INTEGER I;STRING S);
! I don't understand the error number stuff. All errors numbered 200
have been added by me and can be arbitrarily reassigned.
PJ 8/30/76
I should have made this comment earlier, but didn't. The error
number is meaningless to the user. It is even useful to the
people modifying PARSE, to the extent that it helps to figure
out where the error is coming in from in the source program.
Actually, the error numbers should be used to indicate on
which page or line the code is. Numbering may be useful
for the user if we want to have a small parser, and store
error messages on a disk file.
MSM 3/5/78 ;
α INTEGER L1,L2; BOOLEAN PROCEED; INTEGER COMMAND_CHAR; BOOLEAN TERSE;
RPTR(ANY_CLASS) PROCEDURE ERROR_RECOVERY(INTEGER I);
IF I=13 THEN α RPTR(ID_LIST)D1;
OUTSTR(CRLF& "Continue will declare it internally");
D1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[D1]←TRANS_VALUE;
ID_LIST:BLOCK_LEVEL_OF_DEFN[D1]←BLOCK_LEVEL;
RETURN(D1);
β
ELSE
IF I=55 THEN α string s; s←null;
WHILE LENGTH(S)=0 AND ¬AUTO_PROCEED DO α
OUTSTR(CRLF& "Type in correct file"&crlf& "*");
s←inchwl; PROCEED←TRUE;
if length(s)≠0 then infile←s;
β;
RETURN(NULL_RECORD);
β
ELSE
RETURN(NULL_RECORD);
RPTR(ANY_CLASS) C1;
string source_pos;
STRING LINE,LINER;
source_pos←"File "& INFILE& ", Page "& CVS(PAGENUM+1)& ", Line "& CVS(LINENUM);
LINE←CURLINE; LINER←CURLINER;
IF CHANIN≤-1 THEN α ! SUBSTITUTE DUMMY PARAMETERS OF MACRO FOR REAL THING;
INTEGER I1,PARAM_COUNT;
source_pos← "At "&source_pos&crlf&"inside Macro "¯o_list:id[current_macro];
if liner=space then liner←liner[2 to ∞];
IF (PARAM_COUNT←SOURCE_LIST:NUM[TOP_SOURCE]) > 0
THEN α
string array param_id,param_arg[1:param_count];
RPTR(param_list) param_ptr;
integer l1,l2,temp;
string t;
string procedure subst(string old_string);
α string t,t1,old;
integer brchar,i1;
old←old_string;
t←scan(old,temp,brchar);
while brchar≠0 do
α t1←old[1 to l1];
old←old[l2 to ∞];
for i1←1 step 1 until param_count do
if equ(t1,param_arg[i1])
then t←t¶m_id[i1];
t←t&scan(old,temp,brchar);
β;
return(t);
β;
param_ptr←macro_list:params[current_macro];
source_pos←source_pos&"(";
for i1←1 step 1 until param_count do
α param_arg[i1]←param_list:id[param_ptr];
param_id[i1]←param_list:user_id[param_ptr];
param_ptr←param_list:next[param_ptr];
source_pos←source_pos¶m_id[i1]&",";
β;
l1←length(source_pos);
source_pos←source_pos[1 to l1-1]&")"&crlf;
l2←(l1←length(param_arg[1]))+1;
t←param_arg[1][1 for 1];
setbreak(temp←getbreak,t,null,"INR");
line←subst(line);
liner←subst(liner);
RELBREAK(TEMP);
β;
β;
WHILE EQU(LINE[1 TO 1], lf) DO GARB←LOP(LINE);
L1←LENGTH(LINER); L2←LENGTH(LINE)-L1; PROCEED←AUTO_PROCEED;
IF ¬PROMPT_FOR_MODIFIABLE_ERROR_ONLY OR global_backup
then α
IF global_backup THEN PROCEED←FALSE;
ifc debug_compile thenc
OUTSTR(crlf & "ERROR TYPE " & CVS(I));
endc
IF I<0 THEN OUTSTR(crlf &"WARNING: ") ELSE OUTSTR(crlf);
OUTSTR(S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
β
ELSE IF PROMPT_FOR_MODIFIABLE_ERROR_ONLY THEN PROCEED←TRUE;
C1←ERROR_RECOVERY(I);
IF ¬LOGGING THEN IF COMPILE_LOGGING THEN OPEN_LOGGING_FILE;
IF LOGGING THEN
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
IF IGNORE_CORRECTION THEN PROCEED←TRUE;
IF I<0 THEN PROCEED←TRUE;
WHILE ¬PROCEED DO
α
CLRBUF; OUTSTR("$"); DO COMMAND_CHAR←INCHRS UNTIL COMMAND_CHAR<0;
COMMAND_CHAR←INCHRW;
CASE COMMAND_CHAR OF
α
["b"] ["B"] α
OUTSTR("ail" & crlf);
IFC debug_compile
THENC BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
[cr] α CLRBUF; PROCEED←TRUE; β;
["c"] ["C"] α OUTSTR("ontinue with default recovery"); PROCEED←TRUE; β;
[lf] α PROCEED←TRUE; AUTO_PROCEED←TRUE; β;
["a"] ["A"] α OUTSTR("utomatic continuation");
IF LOGGING THEN OUTSTR(" and logging");
OUTSTR(".");
PROCEED←TRUE; AUTO_PROCEED←TRUE; IGNORE_CORRECTION←TRUE;
β;
["e"] ["E"] α OUTSTR("dit" & crlf);
CLOSO(CHANLOG);CLOSO(CHANOUT);
EDFILE(INFILE,LINENUM,PAGENUM+1,0);
β;
IFC FALSE THENC
["I"] ["i"] α OUTSTR("gnore trying to modify"&CRLF);
PROCEED←TRUE; IGNORE_CORRECTION←TRUE;
β;
ENDC
["r"] ["R"] α
OUTSTR("estart"); CURLINE←CURLINER←null;
USERERR(0,1,NULL,"S"); ! THIS IS A HACK AND SHOULD BE CHANGED
AS SOON AS POSSIBLE;
β;
["x"] ["X"] α OUTSTR("it" & crlf);
USERERR(0,1,NULL,"X"); ! DITTO ABOVE COMMENT;
β;
["t"] ["T"] α OUTSTR("erse" & crlf); TERSE←TRUE; β;
["v"] ["V"] α OUTSTR("erbose" & crlf); TERSE←FALSE; β;
["p"] ["P"] IF PATCH_CODE THEN
α
OUTSTR("atch source code; modify following line"&CRLF);
CLRBUF;
LODED(LINER);
CURLINER←INCHWL;
CURLINE←LINE[1 TO L2] & CURLINER;
PATCH_CODE←FALSE;
PROCEED←TRUE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
β
ELSE OUTSTR("atch - ***** sorry, non-patchable error *****"&CRLF);
["m"] ["M"] IF GLOBAL_BACKUP THEN
α STRING S1,S2;
OUTSTR("odify the following" & CRLF);
PARSED_STRING←PARSED_STRING&CURLINER;s2←null;
WHILE ¬EQU(PARSED_STRING,NULL)
DO α CLRBUF;
S1←SCAN(PARSED_STRING,LF_FF_BREAK,BRCHAR);
IF S1[1 FOR 1]=cr or s1[1 for 1] = LF
THEN α s2←s1; S1←scan(parsed_string, lf_ff_break,brchar);β;
IF LENGTH(S1)≠0 THEN α LODED(S1); S1←INCHWL; β;
S2←S2&S1&CRLF;
β;
CURLINE←CURLINER←S2;
OUTSTRING←PARSED_STRING←NULL;
GLOBAL_MODIFIED←PROCEED←TRUE;
GLOBAL_BACKUP←FALSE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
reject←false;
β
ELSE OUTSTR("Sorry can't do backup");
["?"] IF ¬TERSE THEN
α
OUTSTR("Reply [CR] or ""C"" to continue," & crlf &
"[LF] to continue automatically for non modifiable errors," & crlf &
"""A"" to continue automatically," & crlf &
"""E"" to edit source file," & crlf &
"""R"" to restart," & crlf &
"""T"" for terse," & crlf &
"""V"" for verbose," & crlf &
"""X"" to exit");
IFC DEBUG_COMPILE THENC OUTSTR("," & crlf & """B"" to load Bail"); ENDC
IF ¬LOGGING THEN OUTSTR("," & crlf & """L"" for logging");
IF GLOBAL_BACKUP THEN OUTSTR("," & crlf & """M"" for modifying source code");
OUTSTR("." & crlf);
β
ELSE OUTSTR("OPTIONS cr,lf,E,R,T,X,B,L,M,G, and V? for verbose"&CRLF);
["l"] ["L"] IF ¬LOGGING THEN
α
OPEN_LOGGING_FILE;
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
OUTSTR("ogging in file name " & LOGFILE & crlf );
β
ELSE OUTSTR("ogging already");
ELSE OUTSTR(" Unrecognized character; type ""?"" for allowable characters."&crlf)
β;
β;
IF I>0 THEN NUM_OF_ERRORS←NUM_OF_ERRORS+1;
GLOBAL_BACKUP←FALSE;
RETURN(C1);
β;
RPTR(ANY_CLASS) PROCEDURE ERROR_basic_REJECT(INTEGER I;STRING S);
α RPTR (ANY_CLASS)R1; R1←ERROR_basic(I,S); REJECT←TRUE; RETURN(R1); β;
PROCEDURE PRINT(STRING S);
α
ifc debug_compile or true thenc comment used to be only debug_compile ;
INTEGER I,J,K,L;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
J←LENGTH(S);
WHILE J>80 DO
α;
K←80;
WHILE K≤J AND ¬EQU(S[K TO K]," ") DO K←K+1;
IF OUTSTRING ≠ NULL THEN outstring←outstring&crlf&s[1 to K]
ELSE outstring←s[1 to K];
! OUT(CHANOUT,S[1 TO K] & crlf);
S←S[K+1 TO J];
J←J-K;
β;
IF OUTSTRING≠NULL THEN outstring←outstring&crlf&s
ELSE outstring←s;
! OUT(CHANOUT,S & crlf);
elsec
INTEGER I;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
IF OUTSTRING≠NULL THEN outstring←outstring&crlf&s
ELSE outstring←s;
! OUT(CHANOUT,S & crlf);
endc;
β;
procedure file_indent(integer i);
α
typed_page_num ← false;
outstr(" "[1 for 2*i]);
β;
PROCEDURE PRINTOUT;
α
IF OUTSTRING≠NULL THEN OUT(CHANOUT,OUTSTRING&CRLF);
IF REJECT=TRUE
THEN α PARSED_STRING←PARSED_STRING[1 TO LENGTH(PARSED_STRING) - LENGTH(TOKEN)];
CURLINE←token2&curliner; β ELSE
CURLINE←CURLINER;
OUTSTRING←NULL;
ifc dup_file thenc
IF WANT_DUP_FILE AND CHANIN > -1 AND CHANNEW > -1 THEN
OUT(CHANNEW,PARSED_STRING);
endc
PARSED_STRING←NULL;
β;
RPTR(ANY_CLASS) PROCEDURE ERROR(INTEGER I;STRING S);
RETURN(ERROR_BASIC(I,S));
RPTR(ANY_CLASS) PROCEDURE ERROR_REJECT(INTEGER I;STRING S);
RETURN(ERROR_BASIC_REJECT(I,S));
PROCEDURE UNDEFINED_VAR(STRING VAR(NULL));
ERROR(0,"UNDEFINED VARIABLE "&VAR);
PROCEDURE UNAFFIXED_VAR(STRING VAR(NULL));
ERROR(0,"UNAFFIXED VARIABLE "&VAR);
! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy;
procedure process_switches(RPTR(file) F);
α RPTR(file_switch) swt;
swt ← file:switches[F];
while swt≠null_record do
α integer i;
for i ← 0 step 1 until switch_max do
if equ(file_switch:name[swt], switch_name[i])
then α switch_setting[i] ← true; done β;
if i > switch_max then
begin
outstr("""" & file_switch:name[swt] & """ unknown switch but will pass it through"& crlf);
switch_name[switch_max+1]←switch_name[switch_max+1]&file_switch:name[swt];
end;
swt ← file_switch:next[swt]
β
β;
boolean procedure got_input(RPTR(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
if file:in_bfrs[F]≤0 then file:in_bfrs[F]←12;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
if eof ∧ length(file:ext[F])=0 ∧ length(file:def_ext[f])≠0 then
α "try default"
file:ext[F] ← file:def_ext[F];
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
β "try default";
process_switches(F);
return(¬eof)
β;
boolean procedure got_output(RPTR(file) F; STRING EXT(NULL));
α
string filename;
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
if length(file:ext[F])=0 then file:ext[F] ← file:def_ext[F];
IF ¬EQU(EXT,NULL) THEN FILE:EXT[F]←EXT;
filename ← make_file_name(F);
enter(file:chn[F], filename, file:eof[F]); process_switches(F);
return(¬eof)
β;
procedure open_logging_file;
if ¬log_file_open then
α;
LOG_file←new_record(file);
copy_file_record(LOG_file,BIN_file);
file:mode[LOG_file]←0; file:in_bfrs[LOG_file]← 0;
file:out_bfrs[LOG_file]←12; file:ext[LOG_file] ← "LOG";
file:device[LOG_file]← "DSK";
file:name[LOG_file]←file:name[AL_file];
if ¬got_output(LOG_file) then
usererr(0, 1, "can't get output");
CHANLOG ← file:chn[LOG_file];
LOGFILE←make_file_name(LOG_file);
log_file_open←true;
logging←true;
β;
ifc dup_file thenc
procedure open_NEW_AL_file(RPTR(FILE)B; STRING EXT);
α
NEW_file←new_record(file);
copy_file_record(NEW_file,B);
file:mode[NEW_file]←0; file:in_bfrs[NEW_file]← 0;
file:out_bfrs[NEW_file]←12; file:ext[NEW_file] ← EXT;
file:device[NEW_file]← "DSK";
file:name[NEW_file]←file:name[PRESENT_file];
CHANNEW ← (file:chn[NEW_file] ← getchan);
if ¬got_output(NEW_file,EXT) then
usererr(0, 1, "can't get output");
NEWFILE←make_file_name(NEW_file);
β;
endc
RPTR (file) procedure open_new_file(reference string s);
begin string word;
integer ignore_blanks_break,file_name_break,ppn_break,break;
RPTR(file)F;
integer procedure ignore_blanks(reference string s);
begin integer break; scan(s, ignore_blanks_break, break); return(break) end;
string procedure filwrd;
begin ignore_blanks(s); return(scan(s, file_name_break, break)) end;
setbreak(
ignore_blanks_break ← getbreak, space & tab, cr, "XRK");
setbreak(
file_name_break ← getbreak, "[:.," & lf, cr, "ISK");
setbreak(
ppn_break ← getbreak, "]" & lf, cr, "ISK");
F←new_record(file);
word ← filwrd; file:chn[F] ← -1; ! file has not been opened flag;
if break=":" then begin file:device[F] ← word; word ← filwrd end;
file:name[F] ← word;
if break="." then file:ext[F] ← filwrd;
if break="[" then
begin
ignore_blanks(s); file:ppn[F] ← "[" & scan(s, ppn_break, break) & "]";
if break="]" then begin ignore_blanks(s); break ← lop(s) end;
end;
if length(file:device[F])=0 then file:device[F] ← "DSK";
return(F);
end;
PROCEDURE CHECK_WANT_COPY;
α String save; save←"Y";
IF EQU(FILE:NAME[PRESENT_FILE],NULL)
THEN IF now_top_file then FILE:NAME[PRESENT_FILE]←"ALMAIN" else save←"N";
! OUTSTR(CRLF&"Teletype input requested. Want to save on disk?(Y or N)");
! ALTERNATIVE METHOD SAVE←INCHRW;
IF SAVE = "Y"
THEN
α RPTR(FILE)F;
F←NEW_RECORD(FILE);
copy_file_RECORD(F,PRESENT_FILE);
file:mode[F]←0;file:in_bfrs[F]←0;
file:out_bfrs[F]←12; if file:ext[F]=null then file:ext[f]←"TTY";
file:chn[f]←-1;
FILE:DEVICE[F]←"DSK";
IF ¬GOT_OUTPUT(F) THEN USERERR(0,1,"Can't get output");
CHANTTYO←FILE:CHN[F];
β
ELSE CHANTTYO←-1;
β;
BOOLEAN PROCEDURE ASK_WANT_DUP_FILE;
α STRING S;
OUTSTR(CRLF&"WANT TO SAVE DUPLICATE FILE (Y OR N) ? ");
S←INCHRW; IF S="Y" OR S="y" then RETURN(TRUE) else return(false);
β;
! push_source_list,pop_source_list,new_expr_rec;
RPTR(SOURCE_LIST) PROCEDURE PUSH_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
RPTR(SOURCE_LIST) S;
S←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:NEXT[S]←S1;
SOURCE_LIST:CUR_STRING[S]←CURLINE;
SOURCE_LIST:CUR_STRINGR[S]←TOKEN_FRONT&CURLINER;
SOURCE_LIST:PN[S]←PAGENUM;
SOURCE_LIST:LN[S]←LINENUM;
SOURCE_LIST:CHAN[S]←CHANIN;
SOURCE_LIST:FILE_NAME[S]←INFILE;
SOURCE_LIST:FILE_PTR[S]←PRESENT_FILE;
SOURCE_LIST:CHANTTYO[S]←CHANTTYO;
SOURCE_LIST:CHANNEW[S]←CHANNEW;
! SOURCE_LIST:P_STRING[S]←PARSED_STRING;
! PARSED_STRING←NULL;
PRINTOUT;
CHANTTYO←-1;
CURLINE←CURLINER←NULL;
RETURN(S);
β;
RPTR(SOURCE_LIST) PROCEDURE POP_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
CURLINE←SOURCE_LIST:CUR_STRING[S1];
CURLINER←SOURCE_LIST:CUR_STRINGR[S1];
PAGENUM←SOURCE_LIST:PN[S1];
LINENUM←SOURCE_LIST:LN[S1];
CHANIN←SOURCE_LIST:CHAN[S1];
PRESENT_FILE←SOURCE_LIST:FILE_PTR[S1];
INFILE←SOURCE_LIST:FILE_NAME[S1];
CHANTTYO←SOURCE_LIST:CHANTTYO[S1];
CHANNEW←SOURCE_LIST:CHANNEW[S1];
! PARSED_STRING←SOURCE_LIST:P_STRING[S1];
RETURN(SOURCE_LIST:NEXT[S1]);
β;
! id info processing routines;
! FLAGS
BIT 35 USE
34 DEFINE
33 AFFIX
0-9 PAGENUM
10-19 LINENUM ;
DEFINE RID1=[RPTR(ID_LIST)R1];
DEFINE ARID1=[RPTR(ID_LIST,ARRAY_LIST)R1; INTEGER TTOKEN(ID_TOKEN)];
PROCEDURE USE(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '1;
BOOLEAN PROCEDURE USED(RID1);
RETURN(ID_LIST:FLAGS[R1] LAND '1);
PROCEDURE UNFIX(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LAND '777777777773;
PROCEDURE PUT_ID_PAGE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_ID_LINE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE ID_PAGE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 10)LAND '1777);
INTEGER PROCEDURE ID_LINE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 20)LAND '1777);
DEFINE AID1= [RPTR(ARRAY_LIST) A1];
BOOLEAN PROCEDURE array_USED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '1);
BOOLEAN PROCEDURE ARRAY_DEFINED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '2);
BOOLEAN PROCEDURE ARRAY_AFFIXED(AID1);
RETURN(ARRAY_LIST:FLAGS[A1] LAND '4);
PROCEDURE ARRAY_USE(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '1;
PROCEDURE ARRAY_DEFIN(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '2;
PROCEDURE ARRAY_AFFIX(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LOR '4;
PROCEDURE ARRAY_UNFIX(AID1);
ARRAY_LIST:FLAGS[A1]←ARRAY_LIST:FLAGS[A1] LAND '777777777773;
PROCEDURE PUT_ARRAY_PAGE(AID1);
ARRAY_LIST:FLAGS[A1]←(((ARRAY_LIST:FLAGS[A1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_ARRAY_LINE(AID1);
ARRAY_LIST:FLAGS[A1]←(((ARRAY_LIST:FLAGS[A1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE ARRAY_PAGE(AID1);
RETURN((ARRAY_LIST:FLAGS[A1] ROT 10)LAND '1777);
INTEGER PROCEDURE ARRAY_LINE(AID1);
RETURN((ARRAY_LIST:FLAGS[A1] ROT 20)LAND '1777);
DEFINE PID1= [RPTR(PROCEDURE_LIST) P1];
BOOLEAN PROCEDURE PROCEDURE_USED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '1);
BOOLEAN PROCEDURE PROCEDURE_DEFINED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '2);
BOOLEAN PROCEDURE PROCEDURE_AFFIXED(PID1);
RETURN(PROCEDURE_LIST:FLAGS[P1] LAND '4);
PROCEDURE PROCEDURE_USE(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '1;
PROCEDURE PROCEDURE_DEFIN(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '2;
PROCEDURE PROCEDURE_AFFIX(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LOR '4;
PROCEDURE PROCEDURE_UNFIX(PID1);
PROCEDURE_LIST:FLAGS[P1]←PROCEDURE_LIST:FLAGS[P1] LAND '777777777773;
PROCEDURE PUT_PROCEDURE_PAGE(PID1);
PROCEDURE_LIST:FLAGS[P1]←(((PROCEDURE_LIST:FLAGS[P1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_PROCEDURE_LINE(PID1);
PROCEDURE_LIST:FLAGS[P1]←(((PROCEDURE_LIST:FLAGS[P1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE PROCEDURE_PAGE(PID1);
RETURN((PROCEDURE_LIST:FLAGS[P1] ROT 10)LAND '1777);
INTEGER PROCEDURE PROCEDURE_LINE(PID1);
RETURN((PROCEDURE_LIST:FLAGS[P1] ROT 20)LAND '1777);
BOOLEAN PROCEDURE DEFINED(ARID1);
IF TTOKEN=ID_TOKEN THEN
RETURN(ID_LIST:FLAGS[R1] LAND '2)
ELSE RETURN(ARRAY_DEFINED(R1));
BOOLEAN PROCEDURE AFFIXED(ARID1);
IF TTOKEN=ID_TOKEN THEN
RETURN(ID_LIST:FLAGS[R1] LAND '4)
ELSE RETURN(ARRAY_AFFIXED(R1));
PROCEDURE DEFIN(ARID1);
IF TTOKEN=ID_TOKEN THEN
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '2
ELSE ARRAY_DEFIN(R1);
PROCEDURE AFFIX(ARID1);
IF TTOKEN=ID_TOKEN THEN
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '4
ELSE ARRAY_AFFIX(R1);
! read;
INTEGER BRCHAR2;
STRING PROCEDURE KNVRT(STRING OLD_STR);
RETURN( SCAN(OLD_STR, KNVRT_BREAK, BRCHAR2));
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT,TEXT2;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN > -1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT;
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN>-1 THEN α STRING CURR;
CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
IF CHANTTYO≥0 THEN OUT(CHANTTYO, CURLINE);
macro_stack_top←macro_st2; macro_st2←null_record;β;
IF CHANIN≤-1 THEN
α "pop macro"
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
macro_stack_top←macro_st2←SOURCE_LIST:macro_stack_TOP[TOP_SOURCE];
CURRENT_MACRO←SOURCE_LIST:CUR_MACRO[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
IF (BTABLE=WORD_r_BREAK) OR (BTABLE=word_s_break) OR (BTABLE=non_digit_break)
then α brchar←space; return(text); β;
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
printout;
RELEASE(CHANIN);
if channew ≥ 0 AND (NUM_OF_ERRORS_MODIFIED >0)
then α BOOLEAN FLAG;
IF ¬ASK_WANT_DUP_FILE THEN RENAME(CHANNEW,NULL,0,FLAG);
RELEASE(CHANNEW);
β;
IF EQU(FILE:DEVICE[PRESENT_FILE],"TTY")
THEN if chanttyo ≥ 0 then RELEASE(CHANTTYO);
CURRENT_MACRO←NULL_RECORD;
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←POP_SOURCE_LIST(TOP_SOURCE);
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN
IF BLOCK_LEVEL > 0
THEN ERROR(500,"End of file encountered unexpectedly"&crlf&
"Probably BEGIN-ENDs have not been matched.")
ELSE RETURN(NULL);
TEXT2←SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN>-1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT2&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT2;
TEXT←TEXT&TEXT2;
β;
TOKEN2←TEXT;
IFC FULL_SET THENC RETURN(KNVRT(TEXT)); ELSEC RETURN(TEXT); ENDC
β;
! macro handling routine;
BOOLEAN procedure macro_handler;
α "macro_handler"
INTEGER HASH_ENTRY; STRING MACRO_NAME;
INTEGER PARAM_COUNT;
RPTR (MACRO_LIST) MAC_POINT;
RPTR (PARAM_LIST) TOP_PARAM, NEW_PARAM, LAST_PARAM;
BOOLEAN STATUS;
LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
STATUS←FALSE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GOTO FLUSH;
β;
STATUS←TRUE;
do α "define_macro"
INSIDE_MACRO_DEFINITION←TRUE;
PARAM_COUNT←0; GET_TOKEN;
INSIDE_MACRO_DEFINITION←FALSE;
IF TYPE_OF_TOKEN≠undeclared_token and SPECIAL_INFO=BLOCK_LEVEL
THEN F_STATE(0,56,"Can only define unreserved ID's.");
MACRO_NAME←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"(") THEN
α "macro_parameters"
TOP_PARAM←LAST_PARAM←NEW_RECORD(PARAM_LIST);
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token
THEN F_STATE(0,57,"Can only use unreserved ID's as parameter names.");
PARAM_COUNT←PARAM_COUNT+1; NEW_PARAM←NEW_RECORD(PARAM_LIST);
PARAM_LIST:NEXT[LAST_PARAM]←NEW_PARAM;
PARAM_LIST:USER_ID[NEW_PARAM]←TOKEN; LAST_PARAM←NEW_PARAM;
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
α
ERROR(58,"Need either comma or right paren here.");
REJECT←TRUE; TOKEN←")";
β;
β;
TOP_PARAM←PARAM_LIST:NEXT[TOP_PARAM];
GET_TOKEN;
β "macro_parameters";
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(59,"Need = here.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠MACRO_BODY_TOKEN THEN F_STATE(0,60,"MACRO BODY DEFINITION REQUIRES DEFINITION BETWEEN ⊂ AND ⊃")
ELSE
α
! bind macros;
if param_count>0 then
α "PARAMS"
string array param_id, param_arg[1:param_count];
integer i,width,digits;
string t1;
string t, processed_token;
STRING BREAK_STRING;
string t2;
RPTR(param_list) param_ptr;
param_ptr←top_param;
BREAK_STRING←NULL;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(-2,0);
if chanin>0 then t1←"00" else t1←cvs(abs(chanin));
for i ← 1 step 1 until param_count do
α
param_id[i]←param_list:user_id[param_ptr];
param_arg[i]←(param_list:id[param_ptr]← "∀_"&MACRO_NAME&t1 & "__"&cvs(i));
param_ptr←param_list:next[param_ptr];
β;
SETFORMAT(WIDTH,DIGITS);
processed_token← NULL;
do α
integer brchar,brchar2;
t2←scan(token,non_blank_break,brchar);
if t2≠null then processed_token←processed_token&t2;
t←scan(token,word_s_break,brchar2);
if t≠null then
α for i←1 step 1 until param_count do
if equ(t,param_id[i]) then t←param_arg[i];
processed_token←processed_token&t;
β;
if brchar2≠null then processed_token←processed_token&brchar2;
β until length(token)=0;
token←processed_token;
β "PARAMS";
! done binding macros;
β;
if chanin≤-1
then mac_point←insert_entry(macro_name,macro_in_macro_type_table)
else mac_point←insert_entry(macro_name,macro_type_table);
MACRO_LIST:VALUE[MAC_POINT]←TOKEN;
MACRO_LIST:NUM[MAC_POINT]←PARAM_COUNT;
MACRO_LIST:PARAMS[MAC_POINT]←TOP_PARAM;
MACRO_LIST:BLOCK_LEVEL_OF_DEFN[MAC_POINT]←BLOCK_LEVEL;
get_token;
β "define_macro"
until ¬equ(token, ",");
if equ(token, ";") then reject ← true;
FLUSH: RETURN(STATUS);
β "macro_handler";
! expand_macro;
PROCEDURE EXPAND_MACRO(RPTR(MACRO_LIST)CMACRO);
α RPTR(macro_list) m1;
STRING PROCESSED_BODY;
RPTR(SOURCE_LIST)NEW_SOURCE2;
PROCESSED_BODY←NULL;
NEW_SOURCE2←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CUR_MACRO[NEW_SOURCE2]←CURRENT_MACRO;
CURRENT_MACRO←CUR_MACRO;
α "expand macro"
STRING MAC_ID; RPTR(PARAM_LIST) PARAMS;
STRING BODY;
INTEGER BRCHAR2;
M1←CMACRO;
PARAMS←MACRO_LIST:PARAMS[M1];
MAC_ID←MACRO_LIST:ID[M1];
read(non_blank_break); token←read(word_R_break);
if token=null then token←read(word_s_break);
IF ¬EQU(BRCHAR,"(") AND PARAMS≠NULL
THEN ERROR(59,"Parametered macro used without params.")
ELSE IF ¬EQU(BRCHAR,"(")
THEN
α
IF TOKEN= NULL
THEN α CURLINER←BRCHAR&CURLINER;
PARSED_STRING←PARSED_STRING[1 TO ∞ - 1];
β
ELSE α CURLINER←TOKEN2&CURLINER;
parsed_string←parsed_string[1 to length(parsed_string) - length(token)]; β;
BODY←MACRO_LIST:VALUE[M1];
β
ELSE
α "macro parameters"
STRING T,t2r,t3;
FOR I←1 STEP 1 UNTIL MACRO_LIST:NUM[M1] DO
α RPTR(MACRO_LIST)SUB_MACRO;
IF EQU(TOKEN,")") THEN
ERROR(60,"Number of parameters disagree with definition.");
GET_TOKEN(true);
SUB_MACRO←INSERT_ENTRY(PARAM_LIST:ID[PARAMS],MACRO_IN_MACRO_TYPE_TABLE);
MACRO_LIST:VALUE[SUB_MACRO]←TOKEN;
IF EQU(TOKEN,"-") THEN
BEGIN
GET_TOKEN;
IF TYPE_OF_TOKEN=NUMERIC_TOKEN THEN
MACRO_LIST:VALUE[SUB_MACRO]←"-"&TOKEN
ELSE REJECT←TRUE;
END;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(62,"NEED EITHER COMMA OR RIGHT PAREN HERE;
if you use more than one token as argument to a macro call, enclose it between the
macro delimiters ⊂⊃");
PARAMS←PARAM_LIST:NEXT[PARAMS];
β;
IF ¬EQU(TOKEN,")") THEN ERROR(62,"Number of parameters don't match the defn.");
body←macro_list:value[m1];
β "macro parameters";
PROCESSED_BODY←processed_body&body;
β "expand macro";
SOURCE_LIST:NUM[NEW_SOURCE2]←MACRO_LIST:NUM[M1];
SOURCE_LIST:NEXT[NEW_SOURCE2]←TOP_SOURCE;
SOURCE_LIST:CUR_STRING[NEW_SOURCE2]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE2]←CURLINER;
SOURCE_LIST:PN[NEW_SOURCE2]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE2]←LINENUM;
SOURCE_LIST:MACRO_STACK_TOP[NEW_SOURCE2]←MACRO_STACK_TOP;
SOURCE_LIST:MACRO_STRING[NEW_SOURCE2]←MACRO_STRING;
SOURCE_LIST:FILE_PTR[NEW_SOURCE2]←PRESENT_FILE;
SOURCE_LIST:CHAN[NEW_SOURCE2]←CHANIN;
IF CHANIN≥0 THEN CHANIN←-1 ELSE CHANIN←CHANIN-1;
MACRO_STRING←processed_body;
CURLINE←CURLINER←processed_body;
TOP_SOURCE←NEW_SOURCE2;
GET_TOKEN;
WHILE EQU(TOKEN,"DEFINE") DO
α
macro_handler; get_token; GET_TOKEN;
β;
β;
! get_token;
! THIS PROCEDURE GETS THE NEXT TOKEN.
STRING TOKEN ← TOKEN FOUND
INTEGER TYPE_OF_TOKEN← SPECIAL_TOKEN, NUMERIC_TOKEN, STRING_TOKEN, ID_TOKEN,
MACRO_TOKEN, METRIC_TOKEN, UNDEFINED_TOKEN, RESERVED_TOKEN
ARRAY_TOKEN, PROCEDURE_TOKEN
INTEGER TYPE_OF_RES_WORD ← -VE IF NOT RESERVED WORD
INTEGER ID_TYPE ← VALID FOR TYPE_OF_TOKEN=ID_TOKEN
INTEGER ARRAY_TYPE ← VALID FOR TYPE_OF_TOKEN=ARRAY_TOKEN
INTEGER PROCEDURE_TYPE ← VALID FOR TYPE_OF_TOKEN=PROCEDURE_TOKEN
INTEGER SPECIAL_INFO ← PERTAINS TO INFO ABOUT RES_WORD
INTEGER BLOCK_LEVEL_OF_DEFN ← PERTAINS TO BLOCK LEVEL OF DEFN
INTEGER RESERVED_TOKEN_PTR← POINTER TO POSITION IN RESERVED,COM[0:RESERVED_HASHER]
REAL REALNUM← REAL NUMBER FOUND
RPTR TOKEN_PTR← GENERAL POINTER TO TOKEN FOUND AS ID, ETC;
RECURSIVE PROCEDURE GET_TOKEN(boolean noexpand(false));
α "get_token" BOOLEAN T; INTEGER POINT;
RECORD_POINTER(MACRO_LIST) PROCEDURE LOOK_FOR_MACRO;
α RECORD_POINTER (MACRO_LIST) R1;
IF MACRO_STACK_TOP≠NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_IN_MACRO_TYPE_TABLE);
IF R1=NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_TYPE_TABLE);
RETURN(R1);
β;
! IF REJECT THEN α REJECT←FALSE; ! ************ ; ! RETURN; ! ************; ! β;
IF REJECT
THEN α CURLINER←TOKEN2&CURLINER;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING[1 TO LENGTH(PARSED_STRING) - LENGTH(TOKEN2)];
REJECT←FALSE; β;
BLOCK_LEVEL_OF_DEFN←RESERVED_TOKEN_PTR←
ID_TYPE←TYPE_OF_RES_WORD←SPECIAL_INFO←-100;
TOKEN_PTR←NULL_RECORD;
TYPE_OF_TOKEN←special_token; T←TRUE;
WHILE T DO
α "while_T"
TOKEN_FRONT←READ(non_blank_break); TOKEN←READ(word_R_break);
IF EQU(TOKEN,NULL)
THEN
α "isolated break"
CASE BRCHAR OF
α
["."]
α REAL NUM; STRING S1; S1←CURLINER[2 FOR ∞];
IF "0"≤S1≤"9"
THEN α NUM←REALSCAN(CURLINER,BRCHAR);
TYPE_OF_TOKEN←numeric_token; REALNUM←NUM; TOKEN←CVG(NUM) β
ELSE α TOKEN2←TOKEN←"."; CURLINER←CURLINER[2 TO ∞]; β;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&"."&S1[1 FOR LENGTH(S1) - LENGTH(CURLINER)];
β;
ELSE ;
[SQUOTE]
α REAL NUM; STRING S1;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&LOP(CURLINER);
IF "0"≤CURLINER[1 FOR 1]≤"7"
THEN α S1←CURLINER; TYPE_OF_TOKEN←numeric_token; REALNUM←NUM;
TOKEN←CVS(NUM); REALNUM←CVO(TOKEN);
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&CURLINER[1 FOR LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE TOKEN2←TOKEN←squote;
β
β;
IF EQU(TOKEN,NULL) THEN α READ(word_S_break); TOKEN2←TOKEN←BRCHAR;
β;
β "isolated break";
IF EQU(TOKEN,OPEN_BRACE) THEN TOKEN←READ(close_brace_break) ELSE T←FALSE;
β "while_T";
if token=delimiter_1
then
α "found_macro_body" integer lvl;
token←read(macro_delimiter_break); type_of_token ← macro_body_token;
if brchar=delimiter_2 then return; ! ******** ;
lvl ← 2; if brchar≠delimiter_1 then error(200, "macro body scan lost");
do
α token ← token & brchar & read(macro_delimiter_break);
if brchar=delimiter_2
then lvl ← lvl-1
else if brchar=delimiter_1
then lvl ← lvl+1
else error(200, "macro body scan lost");
β
until lvl ≤ 0;
return; ! ************* ;
β "found_macro_body";
IF TOKEN=dquote
THEN
α "found_string"
STRING S1;
TOKEN←READ(quote_break); TYPE_OF_TOKEN←string_token;
while curliner=dquote do α IF CHANIN > -1 THEN PARSED_STRING←PARSED_STRING&(S1←lop(curliner));
token ← token & S1 & read(quote_break); β;
! ********* ; RETURN; ! ********** ;
β "found_string";
! look for reserved word;
IF TYPE_OF_TOKEN=special_token
THEN
α POINT←HASH(TOKEN,reserved_hasher);
WHILE ¬EQU(RESERVED[POINT],NULL) AND ¬EQU(RESERVED[POINT],TOKEN) DO
POINT←(POINT+1)MOD reserved_hasher;
IF RESERVED[POINT]=TOKEN
THEN
α "reserved word" INTEGER VAL; TYPE_OF_TOKEN←reserved_token; VAL←COM_TYPE[POINT];
RESERVED_TOKEN_PTR←POINT;
IF VAL≥reserved_hasher
THEN α SPECIAL_INFO←(VAL DIV reserved_hasher); TYPE_OF_RES_WORD←(VAL MOD reserved_hasher); β
ELSE α SPECIAL_INFO←0; TYPE_OF_RES_WORD←VAL; β;
β "reserved word";
α "not reserved"
RECORD_POINTER(ANY_CLASS)POINT,POINT2;
IF ¬("0" ≤ token ≤ "9")
THEN
α "MAC_TEST"
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←ID_TOKEN; BLOCK_LEVEL_OF_DEFN←ID_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β
ELSE
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,ARRAY_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←ARRAY_TOKEN; BLOCK_LEVEL_OF_DEFN←ARRAY_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β
ELSE
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,PROCEDURE_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←PROCEDURE_TOKEN; BLOCK_LEVEL_OF_DEFN←PROCEDURE_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
IF (POINT2←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE))≠NULL_RECORD
THEN
α IF TOKEN_PTR=NULL_RECORD
THEN α TOKEN_PTR←POINT2; TYPE_OF_TOKEN←METRIC_TOKEN;β
ELSE IF DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[POINT2] > BLOCK_LEVEL_OF_DEFN
THEN α TYPE_OF_TOKEN←METRIC_TOKEN; TOKEN_PTR←POINT2;
BLOCK_LEVEL_OF_DEFN←DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
β;
IF (CUR_MACRO←LOOK_FOR_MACRO)≠NULL_RECORD and ¬noexpand
THEN IF TOKEN_PTR=NULL_RECORD OR MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO]>
BLOCK_LEVEL_OF_DEFN
THEN
α "MACRO"
BLOCK_LEVEL_OF_DEFN←MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO];
EXPAND_MACRO(CUR_MACRO);
β "MACRO";
β "MAC_TEST"
ELSE
α "numeric" REAL NUM1,NUM2; INTEGER NUMGARB;
TYPE_OF_TOKEN←numeric_token; NUM1←INTSCAN(TOKEN,NUMGARB);
IF ¬EQU(TOKEN,NULL) THEN ERROR(0,"Illegal token." & crlf & "Garbage after digits will be ignored.");
IF BRCHAR="."
THEN
α STRING S1; S1←CURLINER;
CURLINER←"0"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN2←TOKEN←CVG(NUM1+NUM2);
REALNUM←NUM1+NUM2;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&S1[1 TO LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE IF BRCHAR="@"
THEN
α STRING S1; S1←CURLINER;
CURLINER←"1"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1*NUM2);
REALNUM←NUM1*NUM2;
IF CHANIN > -1 THEN
PARSED_STRING←PARSED_STRING&S1[1 TO LENGTH(S1) - LENGTH(CURLINER)];
β
ELSE α TOKEN←CVG(NUM1); REALNUM←NUM1; β;
β "numeric";
β "not reserved";
β;
if type_of_token=id_token
then α if ¬inside_declare_p then use(token_ptr);
if id_list:type[token_ptr]=string_value
then if inside_string_declaration
then id_type←string_value
else α type_of_token←string_token; token←id_list:body[token_ptr]; token_ptr←null_record; β
else id_type←id_list:type[token_ptr];
β
else if type_of_token=array_token
then α if ¬inside_declare_p then array_use(token_ptr);
array_type←array_list:type[token_ptr];
β
else if type_of_token=procedure_token
then α if ¬inside_declare_p then procedure_use(token_ptr);
procedure_type←procedure_list:type[token_ptr];
β
else if type_of_token=special_token then type_of_token←undeclared_token;
β "get_token";
boolean procedure check_next_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α string array s[1:10]; integer i1,j1;label l1,l2; string st;
s[1]←s1;s[2]←s2;s[3]←s3;s[4]←s4;s[5]←s5;s[6]←s6;s[7]←s7;s[8]←s8;s[9]←s9;s[10]←s10;
i1←0;st←null;
while s[i1+1]≠null do α i1←i1+1;st←st & s[i1] & ","; β;
if i1 > 1 then
α
l1: get_token;
for j1←1 step 1 until i1
do if equ(token , s[j1]) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need one of "&st& " here, patchable error ");
if patch_code=true
then α patch_code←false; return(false); β
else goto l1;
β else
α
l2: get_token;
if equ(token,s1) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need "&s1&" here, continue will insert it.");
if patch_code = true
then α patch_code←false; return(false); β
else goto l2;
β;
β;
boolean procedure check_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α
reject←true;
return(check_next_token(err_code,err_mess,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10));
β;
boolean procedure check_next_token_type(integer err_code; string err_mess;
integer ttype);
α Label l1;
get_token;
l1: if type_of_token=ttype then return(true);
patch_code←true;
error(err_code,err_mess);
if patch_code=true then α patch_code←false; return(false); β
else goto l1;
β;
boolean procedure check_token_type(integer err_code; string err_mess;
integer ttype);
α
reject←true;
return(check_next_token_type(err_code,err_mess,ttype));
β;
boolean procedure token_equ(string s1,s2(null),s3(null),s4(null),s5(null),
s6(null),s7(null),s8(null),s9(null),s10(null));
α string s;
for s←s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
do if equ(null,s) then return(false)
else if equ(token,s) then return(true);
return(false);
β;
! check, inverse, multiply and divide dimensions; ! CHECK_EXP_TYPE_DIMENS;
RPTR(DIMENS_EXPONENT)
PROCEDURE CHECK_DIMENSIONS_PROG(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR(DIMENS_EXPONENT)II1,II2,II3;STRING SS;BOOLEAN SAME;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α REJECT←FALSE; GET_TOKEN; β;
return(r1);
β;
BOOLEAN PROCEDURE ISNIL_DIMENS(RPTR(DIMENS_EXPONENT) DD);
α BOOLEAN B; B←TRUE; IF DD=NULL_RECORD OR DD=NIL_DIMENS THEN RETURN(TRUE);
redefine xx(temp)= [ B ← B ∧ (DIMENS_EXPONENT:temp[DD] = 0) ; ];
BASIC_DIMENSIONS;
RETURN(B);
β;
SS←NULL;
SAME←TRUE;
II1←D1; II2←D2;
IF II1≠II2 THEN
α IF II1=NULL_RECORD THEN II1←NIL_DIMENS;
IF II2=NULL_RECORD THEN II2←NIL_DIMENS;
redefine xx(temp)= [ IF DIMENS_EXPONENT:temp[II1]≠DIMENS_EXPONENT:temp
[II2] THEN α IF LENGTH(SS)≠0 THEN SS←SS&", temp " ELSE SS←" temp ";
SAME←FALSE;β;];
IF ¬STRICT_DIMEN_CHECK OR (¬ISNIL_DIMENS(II2) AND ¬ISNIL_DIMENS(II1))
THEN α BASIC_DIMENSIONS;
IF SAME THEN II3←II1
ELSE ERROR(122, SS & "Dimensions don't match on "&S&".");
β
ELSE IF ¬ISNIL_DIMENS(II1) THEN II3←II1 ELSE II3←II2;
β
ELSE IF ISNIL_DIMENS(II1) THEN II3←NIL_DIMENS ELSE II3←II1;
IF SAME THEN RETURN(II3);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE INVERSE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←-DIMENS_EXPONENT:temp[D2];];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE SQRT_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[D2]/2;];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE MULTIPLY_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←D3;
β
ELSE
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[d2]+
DIMENS_EXPONENT:temp[D3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE DIVIDE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←INVERSE_DIMENSIONS(D3);
β
ELSE
α
D1←NEW_RECORD(DIMENS_EXPONENT);
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[D2]-
DIMENS_EXPONENT:temp[D3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS_PROG(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α
CHECK_DIMENSIONS_PROG(ERROR_MESS,PTR,EXP_DIMENS);
IF EXP_TYPE=DESIRED_EXP_TYPE THEN RETURN (TRUE) ELSE RETURN (FALSE);
β;
! check_entry,insert_entry into tables;
RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
α
RPTR(ANY_CLASS)R1;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α R1←SYMBOL_TABLE[HASH(S,ID_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,ID_LIST:NAME[R1]) DO R1←ID_LIST:NEXT[R1];
β;
[array_TYPE_TABLE] α R1←array_SYMBOL_TABLE[HASH(S,array_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,array_LIST:NAME[R1]) DO R1←array_LIST:NEXT[R1];
β;
[procedure_TYPE_TABLE] α R1←procedure_SYMBOL_TABLE[HASH(S,procedure_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,procedure_LIST:NAME[R1]) DO R1←procedure_LIST:NEXT[R1];
β;
[MACRO_TYPE_TABLE] α R1←MACRO_TABLE[HASH(S,MACRO_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[R1]) DO R1←MACRO_LIST:NEXT[R1];
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α R1←MACRO_STACK_TOP;
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[MACRO_STACK:LIST_PTR[R1]])
DO R1←MACRO_STACK:STACK_LINK[R1];
IF R1≠NULL_RECORD THEN R1←MACRO_STACK:LIST_PTR[R1];
β;
[DIMENSION_TYPE_TABLE]
α R1←DIMENS_TABLE[HASH(S,METRIC_HASHER)];
WHILE R1≠NULL AND ¬ EQU(S,DIMENS_EXPONENT:NAME[R1]) DO R1←DIMENS_EXPONENT:NEXT[R1];
β
β;
RETURN(R1);
β;
RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S; INTEGER TABLE_TYPE;
RPTR(ANY_CLASS) RR1(NULL_RECORD));
α
RPTR(ANY_CLASS) R1; INTEGER INDEX;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(ID_LIST) ELSE R1←RR1;
ID_LIST:NEXT[R1]←SYMBOL_TABLE[INDEX←HASH(S,ID_HASHER)];
ID_LIST:NAME[R1]←S;
SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α ID_LIST:LAST[R1]←TOP_ID;
ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_ID_PAGE(R1); PUT_ID_LINE(R1);
TOP_ID←R1;DEC_NUM←DEC_NUM+1; β;
β;
[array_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(array_LIST) ELSE R1←RR1;
array_LIST:NEXT[R1]←array_SYMBOL_TABLE[INDEX←HASH(S,array_HASHER)];
array_LIST:NAME[R1]←S;
array_SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α array_LIST:LAST[R1]←TOP_array;
array_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_array_PAGE(R1); PUT_array_LINE(R1);
top_array←R1;array_DEC_NUM←array_DEC_NUM+1; β;
β;
[procedure_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(procedure_LIST) ELSE R1←RR1;
procedure_LIST:NEXT[R1]←procedure_SYMBOL_TABLE[INDEX←HASH(S,procedure_HASHER)];
procedure_LIST:NAME[R1]←S;
procedure_SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α procedure_LIST:LAST[R1]←TOP_procedure;
procedure_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_procedure_PAGE(R1); PUT_procedure_LINE(R1);
top_procedure←R1;procedure_DEC_NUM←procedure_DEC_NUM+1; β;
β;
[MACRO_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(MACRO_LIST) ELSE R1←RR1;
MACRO_LIST:NEXT[R1]←MACRO_TABLE[INDEX←HASH(S,MACRO_HASHER)];
MACRO_LIST:ID[R1]←S;
MACRO_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α MACRO_LIST:LAST[R1]←TOP_MACRO;
TOP_MACRO←R1; MACRO_DEC_NUM←MACRO_DEC_NUM+1; β;
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α
RPTR (macro_list)r2;
IF RR1=NULL_RECORD THEN R2←NEW_RECORD(MACRO_list) ELSE R2←RR1;
r1←new_record(macro_stack);
MACRO_STACK:STACK_LINK[R1]←macro_stack_top;
macro_stack:list_ptr[r1]←r2;
MACRO_STACK_TOP←R1;
macro_list:id[r2]←s;
R1←R2;
β;
[DIMENSION_TYPE_TABLE]
α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(DIMENS_EXPONENT) ELSE R1←RR1;
DIMENS_EXPONENT:NAME[R1]←S;
DIMENS_EXPONENT:NEXT[R1]←DIMENS_TABLE[INDEX←HASH(S,METRIC_HASHER)];
DIMENS_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α DIMENS_EXPONENT:LAST[R1]←TOP_DIMENS;
TOP_DIMENS←R1; DIMEN_DEC_NUM←DIMEN_DEC_NUM+1; β;
β
β;
RETURN(R1);
β;
! expression evaluation routines;
RCLASS EXPR (STRING BODY; INTEGER TYPE; RPTR(DIMENS_exponent)DIMEN; RPTR(EXPR)NEXT);
SIMPLE INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
α INTEGER L,M,U;
L←LB; U←UB;
DO α M←(U+L)/2;
IF A[M]=VAL THEN RETURN(M)
ELSE IF A[M]>VAL THEN U←M-1
ELSE L←M+1;
β UNTIL L>U;
RETURN(0);
β;
define #ntype=10;
SIMPLE INTEGER PROCEDURE FUNC(INTEGER ARRAY T);
α INTEGER I,R; R←0;
FOR I←0 STEP 1 UNTIL 4 DO R←R*#NTYPE + T[I];
RETURN(R);
β;
RPTR (EXPR) PROCEDURE MK_EXPR
(STRING BODY; INTEGER TYPE; RPTR(DIMENS_EXPONENT)DIMEN);
α RPTR(EXPR)X; X←NEW_RECORD(EXPR);
EXPR:BODY[X]←BODY; EXPR:TYPE[X]←TYPE;
EXPR:DIMEN[X]←DIMEN; RETURN(X);
β;
! OP, OP_TYPE,RES_TYPE,ARG1, ARG2, ARG3, DIMENR, DIMEN1, DIMEN2, DIMEN2,RESULT ;
REQUIRE "⊂⊃⊂⊃" DELIMITERS;
DEFINE OPERATIONS = ⊂
XX("¬", NOT_X, #SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D, NOT)
XX("≡", EQV_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, EQV)
XX("∧", AND_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, AND)
XX("∨", OR_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, OR)
XX("⊗", XOR_X, #SC,120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, XOR)
XX("=", SEQ_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SEQ)
XX("≠", SNE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SNE)
XX(">", SGT_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SGT)
XX("<", SLT_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SLT)
XX("≥", SGE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SGE)
XX("≤", SLE_X, #SC,120,#SC, #SC, 0, NIL_D, ANY_D, SAME_D, NIL_D, SLE)
XX("UNIT",UVECT_X, #VT,100,#VT, 0, 0,NIL_D,ANY_D, NIL_D, NIL_D, UVECT)
XX("AXIS",AXIS_X, #VT,100,#RT, 0, 0,NIL_D,ANGL_D, NIL_D, NIL_D, AXIS)
XX("POS",POS_X, #VT,100,#FR, 0, 0,DIST_D,DIST_D,NIL_D, NIL_D, POS)
XX("POS",POS_X, #VT,100,#TR, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, POS)
XX("ORIENT",ORIENT_X, #RT,100,#FR, 0, 0,ANGL_D,DIST_D,NIL_D, NIL_D, ORIENT)
XX("ORIENT",ORIENT_X, #RT,100,#TR, 0, 0,ANGL_D,ANY_D, NIL_D, NIL_D, ORIENT)
XX("INV",RINV_X, #RT,100,#RT, 0, 0,ANGL_D, ANGL_D,NIL_D, NIL_D, TINVRT)
XX("INV",RINV_X, #TR,100,#TR, 0, 0,SAME2_D,ANY_D,NIL_D, NIL_D, TINVRT)
XX("MODULUS",SABS_X, #SC,100,#SC, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, SABS)
XX("MODULUS",SABS_X, #SC,100,#VT, 0, 0,SAME1_D,ANY_D,NIL_D, NIL_D, VMAGN)
XX("MODULUS",SABS_X, #SC,100,#RT, 0, 0,ANGL_D,ANGL_D,NIL_D, NIL_D, RMAGN)
XX("+", PLUS_X, #SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SMUL +1.0)
XX("+", PLUS_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, SADD)
XX("+", PLUS_X, #VT,100,#VT, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SVMUL 1.00000)
XX("+", PLUS_X, #VT,120,#VT, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, VADD)
XX("+", PLUS_X, #FR,210,#VT, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVADD)
XX("+", PLUS_X, #TR,210,#VT, #TR, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVADD)
XX("+", PLUS_X, #FRE,120,#FR, #VT, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVADD)
XX("+", PLUS_X, #TR,120,#TR, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVADD)
XX("-", MINUS_X,#SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, SNEG)
XX("-", MINUS_X,#SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, SSUB)
XX("-", MINUS_X,#VT,100,#VT, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, VSUB NILVECT )
XX("-", MINUS_X,#VT,120,#VT, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, VSUB)
XX("-", MINUS_X,#FRE,120,#FR, #VT, 0, DIST_D, DIST_D, DIST_D, NIL_D, TVSUB)
XX("-", MINUS_X,#TR,120,#TR, #VT, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TVSUB)
XX("*", TIMES_X,#SC,120,#SC, #SC, 0, MULT_D, ANY_D, ANY_D, NIL_D, SMUL)
XX("*", TIMES_X,#VT,120,#SC, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, SVMUL)
XX("*", TIMES_X,#VT,210,#VT, #SC, 0, MULT_D, ANY_D, ANY_D, NIL_D, SVMUL)
XX("*", TIMES_X,#VT,120,#VT, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, VCROSS)
XX("*", TIMES_X,#VT,120,#RT, #VT, 0, SAME2_D,ANGL_D, ANY_D, NIL_D, RVMUL)
XX("*", TIMES_X,#RT,120,#RT, #RT, 0, ANGL_D, ANGL_D, ANGL_D, NIL_D, RRMUL)
XX("*", TIMES_X,#VT,120,#TR, #VT, 0, SAME1_D,ANY_D, ANY_D, NIL_D, TVMUL)
XX("*", TIMES_X,#FRE,120,#TR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, TTMUL)
XX("*", TIMES_X,#TR,120,#TR, #TR, 0, SAME1_D,ANY_D, SAME_D, NIL_D, TTMUL)
XX("MAX",MAX_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MAX)
XX("MIN",MIN_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MIN)
XX("DIV",DIV_X, #SC,120,#SC, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, DIV)
XX("MOD",MOD_X, #SC,120,#SC, #SC, 0, SAME1_D,ANY_D, SAME_D, NIL_D, MOD)
XX("INT",INT_X, #SC,100,#SC, 0, 0, SAME1_D,ANY_D, NIL_D, NIL_D, INT)
! note following is a kludgy way of making v wrt f = (rvmul (orient f) v) ;
XX("WRT",WRT_X, #VT,210,#VT, #RT, 0, SAME1_D,ANY_D, ANGL_D, NIL_D, RVMUL)
XX("→", ⊂→_X⊃, #TR,120,#FR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#FR, #TR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#TR, #FR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX("→", ⊂→_X⊃, #TR,120,#TR, #TR, 0, DIST_D, DIST_D, DIST_D, NIL_D, FTOF)
XX(".", VDOT_X, #SC,120,#VT, #VT, 0, MULT_D, ANY_D, ANY_D, NIL_D, VDOT)
XX("CONSTRUCT",CONSTRUCT_X,
#TR,123,#VT, #VT, #VT, DIST_D, DIST_D, DIST_D, DIST_D, CONSTR)
XX("SQRT",SQRT_X,#SC,100,#SC, 0, 0, SQRT_D, ANY_D, NIL_D, NIL_D,
⊂SSBRTN 1⊃)
XX("SIN", SIN_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 2⊃)
XX("COS", COS_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 3⊃)
XX("TAN", TAN_X,#SC,100,#SC, 0, 0, NIL_D, ANGL_D, NIL_D, NIL_D,
⊂SSBRTN 4⊃)
XX("ASIN",ASIN_X,#SC,100,#SC, 0, 0, ANGL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 5⊃)
XX("ACOS",ACOS_X,#SC,100,#SC, 0, 0, ANGL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 6⊃)
XX("ATAN2",ATAN2_X,#SC,120,#SC, #SC, 0, ANGL_D, ANY_D, SAME_D, NIL_D,
⊂SSBRTN 7⊃)
XX("LOG", LOG_X,#SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 8⊃)
XX("EXP", EXP_X,#SC,100,#SC, 0, 0, NIL_D, NIL_D, NIL_D, NIL_D,
⊂SSBRTN 9⊃)
XX("RUNTIME",RUNTIME_X,#SC,100,#SC,0, 0, TIME_D, TIME_D, NIL_D, NIL_D,
⊂SSBRTN 10⊃)
XX("/", SDIV_X, #SC,120,#SC, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, SDIV)
XX("/", SDIV_X, #VT,120,#VT, #SC, 0, DIVID_D,ANY_D, ANY_D, NIL_D, VSDIV)
XX("↑", STOS_X,#SC, 120,#SC, #SC, 0, NIL_D, NIL_D, NIL_D, NIL_D, STOS)
XX(⊂"("⊃, LPAREN_X,#VT,123,#SC, #SC, #SC, SAME1_D,ANY_D, SAME_D, SAME_D, VMAKE)
XX(⊂"("⊃, LPAREN_X,#RT,120,#VT, #SC, 0, ANGL_D, NIL_D, ANGL_D, NIL_D, AXW_ROTN)
XX(⊂"("⊃, LPAREN_X,#TR,120,#RT, #VT, 0, SAME2_D,ANGL_D, ANY_D, NIL_D, TMAKE)
! XX("SCALAR",⊂#sc+opc⊃, $SMAKE, #SC, 0, 0,SAME1,ANY,);
XX("VECTOR",⊂(#VT+OPC)⊃,#VT,123,#SC,#SC,#SC, SAME1_D,ANY_D, SAME_D,SAME_D, VMAKE)
XX("ROT",⊂(#RT+OPC)⊃, #RT,120,#VT, #SC, 0,ANGL_D, NIL_D, ANGL_D, NIL_D, AXW_ROTN)
XX("FRAME",⊂(#FR+OPC)⊃, #FRE,120,#RT, #VT, 0,DIST_D, ANGL_D, DIST_D, NIL_D, FMAKE)
XX("TRANS",⊂(#TR+OPC)⊃, #TR,120,#RT, #VT, 0,SAME2_D,ANGL_D, ANY_D, NIL_D, TMAKE)
⊃;
DEFINE #SC=SCALAR_VALUE, #VT=VECTOR_VALUE,#TR=TRANS_VALUE,#FR=FRAME_VALUE,#RT=ROT_VALUE,#FRE=FRAME_EXP_VALUE;
DEFINE SAME1_D=1,SAME2_D=2,SAME3_D=3,MULT_D=4,DIVID_D=5,ANGL_D=6,NIL_D=7,ANY_D=8,
SAME_D=9,DIST_D=10,SQRT_D=11,TIME_D=12;
DEFINE XX_MAX=0;
DEFINE OPC=OP_COUNT;
DEFINE OPERATOR_COUNT=0;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =
⊂ REDEFINE OPERATOR_COUNT=OPERATOR_COUNT+1;
REDEFINE NEW_TOTAL= (((OPXXX*#NTYPE+#T1)*#NTYPE+#T2)*#NTYPE+#T3)
*#NTYPE;
IFC XX_MAX>NEW_TOTAL THENC
REQUIRE CRLF&"DISORDERED "&OPQ&CVS(OPXXX) MESSAGE;
ELSEC
REDEFINE XX_MAX = NEW_TOTAL ; ENDC⊃;
OPERATIONS;
REDEFINE OPERATOR_COUNT=0;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =
⊂ REDEFINE OPERATOR_COUNT=OPERATOR_COUNT+1;
REDEFINE NEW_TOTAL= (((OPXXX*#NTYPE+#T1)*#NTYPE+#T2)*#NTYPE+#T3)
*#NTYPE;
NEW_TOTAL, ⊃;
PRELOAD_ARRAY(OCODE,OPERATIONS,INTEGER,1,OPERATOR_COUNT);
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =⊂"STR",⊃;
PRELOAD_ARRAY(SCODE,OPERATIONS,STRING,1,OPERATOR_COUNT);
DEFINE #NDTYPE=20,#NOTYPE=1000;
REDEFINE XX(OPQ,OPXXX,#TYR,OPR,#T1,#T2,#T3,#DR,#D1,#D2,#D3,STR) =⊂
REDEFINE XX_TEMP= ((((#TYR*#NDTYPE+#DR)*#NDTYPE+#D1)*#NDTYPE+#D2)
*#NDTYPE+#D3)*#NOTYPE+OPR;
XX_TEMP,⊃;
PRELOAD_ARRAY(INFO,OPERATIONS,INTEGER,1,OPERATOR_COUNT);
PRESET_WITH "SCALAR","VECTOR","ROT","FRAME","PLANE","TRANS","EVENT","ATOM","WORLD","LABEL";
STRING ARRAY DTYPE[1:10];
PRELOAD_WITH EQV_RES,OR_RES,AND_RES,ORDER_RES,ADD_RES,MULT_RES,WRT_RES;
INTEGER ARRAY RESCL[0:6];
! P_EXP2_BASIC, OPCODE, ERROR HANDLER ;
BOOLEAN PROCEDURE P_EXP2_BASIC;
α RPTR(EXPR)$$1; LABEL DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
RPTR(ANY_CLASS) PROCEDURE ERROR(INTEGER I; STRING S);
α RPTR(ANY_CLASS) R1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
RETURN(R1);
β;
RPTR (EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(EXPR)R);
α STRING S; INTEGER I,INDEX;
RPTR(ANY_CLASS) E1,R1;
RPTR(DIMENS_EXPONENT) ARRAY D[1:3],E[1:3];
STRING ARRAY S1[1:4];
INTEGER ARRAY T[0:4],T1[1:3];
INTEGER TYPOR,DIMR,TYPER;
INTEGER ARRAY DIMINFO[1:3];
INTEGER J;
T[0]←OP; R1←R;
FOR I←1 STEP 1 UNTIL 4 DO T[I]←0;
FOR I←1 STEP 1 UNTIL NARGS MIN 4 DO
α IF (T[I]←EXPR:TYPE[R1])=0
THEN RETURN(MK_EXPR(NULL,0,NULL_RECORD));
R1←EXPR:NEXT[R1]; β;
IF (INDEX←MATINX(FUNC(T),OCODE,1,OPERATOR_COUNT))=0 THEN
α STRING S,S1; S←DTYPE[T[1]];
FOR I← 2 STEP 1 UNTIL NARGS MIN 4 DO
IF T[I]≠0 THEN S←S&", "&DTYPE[T[I]];
IF OP≤OP_COUNT THEN S1←OPERATORS[OP] ELSE
S1←DTYPE[OP-OP_COUNT];
ERROR(5000,"OPERATOR/function "&S1&" CANNOT TAKE OPERANDS/arguments "
&S&CRLF&"CONTINUE WILL GIVE NULL EXPRESSION");
RETURN(MK_EXPR(NULL,0,NULL_RECORD));
β;
I←INFO[INDEX];
J← #NOTYPE;
TYPOR←I MOD J; I← I DIV J;
J←#NDTYPE;
DIMINFO[3]←I MOD J; I←I DIV J;
DIMINFO[2]←I MOD J; I←I DIV J;
DIMINFO[1]←I MOD J; I←I DIV J;
J←#NDTYPE;
DIMR←I MOD J; TYPER←I DIV J;
T1[1]←TYPOR DIV 100;
T1[2]←(TYPOR DIV 10)MOD 10;
T1[3]←TYPOR MOD 10;
R1←R; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
IF R1≠NULL_RECORD THEN
α
STRING SSS;
SSS←(IF OP≤OP_COUNT THEN OPERATORS[OP] ELSE
DTYPE[OP-OP_COUNT]);
D[I]←EXPR:DIMEN[R1];
S1[I]←EXPR:BODY[R1];
R1←EXPR:NEXT[R1];
CASE DIMINFO[I] OF
α
[ANY_D] E[I]←D[I];
[SAME_D] CHECK_DIMENSIONS("arguments "&CVS(I)&","&CVS(I-1)&" of"&sss,
D[I],E[I]←E[I-1]);
[DIST_D] CHECK_DIMENSIONS("requirement of DISTANCE dimension"&
crlf&" on argument "&cvs(i)&" of "&sss,D[I],DISTANCE_DIMENS);
[TIME_D] CHECK_DIMENSIONS("requirement of TIME dimension"&
crlf&" on argument "&cvs(i)&" of "&sss,D[I],TIME_DIMENS);
[ANGL_D] CHECK_DIMENSIONS("requirement of ANGLE dimension"&
crlf&" on argument "&cvs(i)&" of "&sss,D[I],ANGLE_DIMENS);
[NIL_D] CHECK_DIMENSIONS("requirement of DIMENSIONLESS dimension"&
crlf&" or argument "&cvs(i)&" of "&sss,D[I],NIL_DIMENS)
β;
β ELSE DONE;
CASE DIMR OF
α
[SAME1_D] E1←D[1];
[SAME2_D] E1←D[2];
[SAME3_D] E1←D[3];
[MULT_D] E1←MULTIPLY_DIMENSIONS(D[1],D[2]);
[DIVID_D] E1←DIVIDE_DIMENSIONS(D[1],D[2]);
[DIST_D] E1←DISTANCE_DIMENS;
[ANGL_D] E1←ANGLE_DIMENS;
[NIL_D] E1←NIL_DIMENS;
[SQRT_D] E1←SQRT_DIMENSIONS(D[1]);
[TIME_D] E1←TIME_DIMENS;
ELSE ERROR(50000,"PARSER ERROR IN DIMENSION DETERMINATION")
β;
FOR I←1 STEP 1 UNTIL NARGS DO S←S&" "&S1[T1[I]];
RETURN(MK_EXPR("( $"&SCODE[INDEX]&S&")",TYPER,E1));
β;
! exp,bfact,bterm,aexp,term,factor;
! EXP E: BFF | BFF ≡ BFF
BEFACT BFF: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP="(XXXXX(0))";
DEFINE EXP_XX=0,BEFACT_XX=1,BFACT_XX=2,BTERM_XX=3,AEXP_XX=4,TERM_XX=5,FACTOR_XX=6,
PF_XX=7;
! FORWARD RECURSIVE RPTR(EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE PF XXXXX(PF_XX);
RECURSIVE RPTR(EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND TYPE_OF_RES_WORD = ADD_RES THEN
α I←SPECIAL_INFO;
GET_TOKEN; $$1←XXXXX(LEVEL + 1);
$$1←OPCODE(I,1,$$1);
β
ELSE $$1←XXXXX(LEVEL+1);
WHILE TYPE_OF_RES_WORD=RESCL[LEVEL] DO
α I←SPECIAL_INFO;
GET_TOKEN; EXPR:NEXT[$$1] ← XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[EXP_XX] [BTERM_XX]
α
$$1←XXXXX(LEVEL + 1);
IF TYPE_OF_RES_WORD = RESCL[LEVEL] THEN
α I←SPECIAL_INFO;
GET_TOKEN; EXPR:NEXT[$$1]←XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF TYPE_OF_RES_WORD = WRT_RES THEN
α I←SPECIAL_INFO; GET_TOKEN;
! Following is a kludge because v WRT f goes to (RVMUL (ORIENT f) v);
IF I≠WRT_X THEN EXPR:NEXT[$$1]←XXXXX(LEVEL + 1)
ELSE α $$2←XXXXX(LEVEL + 1);
EXPR:NEXT[$$1]←OPCODE(ORIENT_X,1,$$2);
β;
$$1←OPCODE(I,2,$$1);
β;
β;
[PF_XX]
CASE TYPE_OF_TOKEN OF
α
[NUMERIC_TOKEN]
α
$$1←MK_EXPR(TOKEN,SCALAR_VALUE,NIL_DIMENS);
GET_TOKEN;
β;
[ID_TOKEN]
α
$$1←MK_EXPR(TOKEN,ID_TYPE,ID_LIST:DIMEN[TOKEN_PTR]);
GET_TOKEN;
β;
[ARRAY_TOKEN]
α RPTR(ARRAY_LIST) APTR; INTEGER NARGS,ARGS; STRING S;
APTR←TOKEN_PTR; S←"$AREF "&TOKEN;
GET_TOKEN;
IF TOKEN≠"[" THEN ERROR_reject(51,"need a [ after array variable,continue will insert");
GET_TOKEN;
NARGS←arrAy_LIST:#DIMENS[APTR];
FOR ARGS←1 STEP 1 UNTIL NARGS DO
α
$$1←EXP;
CHECK_DIMENSIONS("field of array variable, which should be dimensionless",
nil_dimens, expr:dimen[$$1]);
if expr:type[$$1]≠scalar_value then
error(51,"field of array variable should be a scalar expression");
if args≠nargs and token≠"," then
error_reject(52,"need , between arguments of a array variable")
else if args=nargs and token≠"]" then
error_reject(52,"need ] after last argument of a array variable");
s←s&" "&expr:body[$$1];
get_token;
β;
$$1←mk_expr("("&s&")",array_list:type[aptr],array_list:dimen[aptr]);
β;
[PROCEDURE_TOKEN]
α string s; integer ttype;
rptr(procedure_list)pptr; integer nargs,args;
pptr←token_ptr; s←"$CALL "&TOKEN;
get_token;
IF (nargs← procedure_list:#args[pptr])≠0
then
α
if token≠"(" then error_reject(54,"need ( here for procedure");
get_token;
for args←1 step 1 until nargs do
α
if procedure_list:isid[pptr][args]
then α
ttype←id_list:type[procedure_list:args[pptr][args]];
$$1←exp;
β
else α
ttype←array_list:type[procedure_list:args[pptr][args]];
if type_of_token≠array_token
then error(53,"need array name here");
$$1←MK_EXPR(TOKEN,array_list:type[token_ptr],
array_list:dimen[token_ptr]);
get_token;
β;
if ttype≠expr:type[$$1]
then error(53,"argument "&cvs(args)&" of procedure does not have same type as declared");
check_dimensions("argument "&cvs(args) &" of procedure",
(if procedure_list:isid[pptr][args] then
id_list:dimen[procedure_list:args[pptr][args]] else
array_list:dimen[procedure_list:args[pptr][args]]),
expr:dimen[$$1]);
if args≠nargs and token≠","
then error_reject(54,"need , to separate arguments of a procedure")
else if args=nargs and token≠")"
then error_reject(52,"need ) after last argument of procedure call");
get_token;
s←s&" "&expr:body[$$1];
β;
β;
$$1←mk_expr("("&s&")",procedure_list:type[pptr],
procedure_list:dimen[pptr]);
β;
[RESERVED_TOKEN]
CASE TYPE_OF_RES_WORD OF
α
[abs_res]
α GET_TOKEN; $$1←EXP;I←SPECIAL_INFO;
IF TOKEN≠"|"
THEN ERROR_REJECT(150,"MISMATCHED VERT BAR, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,1,$$1);
β;
[func_res]
α I← SPECIAL_INFO;
GET_TOKEN;
IF TOKEN="("
THEN
α GET_TOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GET_TOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,I2,$$1);
β
ELSE IF I=RUNTIME_X
THEN $$1←OPCODE(I,1,
MK_EXPR("($SMUL 0.0 SECONDS)",SCALAR_VALUE,TIME_DIMENS)
)
ELSE ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
β;
[declare_res]
α I← SPECIAL_INFO + op_count;
GET_TOKEN;
IF TOKEN≠"("
THEN ERROR_REJECT(160,"REQUIRE LEFT PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GET_TOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(I,I2,$$1);
β;
[DEPROACH_res]
α
GET_token;
IF token≠"("
THEN ERROR_REJECT(161,"REQUIRE LEFT PAREN AFTER DEPROACH, WILL INSERT")
ELSE GET_TOKEN;
$$1←EXP;
IF EXPR:TYPE[$$1]≠TRANS_VALUE THEN
ERROR(162,"Can have deproach only for a frame");
IF TOKEN≠")"
THEN ERROR_REJECT(163,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←MK_EXPR("($DEPROACH "&EXPR:BODY[$$1]&" )",
TRANS_VALUE,DISTANCE_DIMENS);
β;
[OPEN_PAREN_RES]
α GET_TOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")" THEN
α WHILE TOKEN="," DO
α GET_TOKEN; $$3←EXP; I2←I2+1;
$$2←EXPR:NEXT[$$2]←$$3;
β;
IF TOKEN≠")"
THEN ERROR_REJECT(160,"MISMATCHED PAREN, WILL INSERT")
ELSE GET_TOKEN;
$$1←OPCODE(LPAREN_X,I2,$$1);
β ELSE GET_TOKEN;
β;
[NOT_RES]
α I←SPECIAL_INFO; GET_TOKEN;
$$1←EXP;
$$1←OPCODE(I,1,$$1);
β;
[OR_res]
α
IF NOT EQU(CURRENT_FRAME,NULL) THEN
$$1←MK_EXPR(CURRENT_FRAME,
trans_VALUE,DISTANCE_DIMENS)
ELSE
BEGIN
ERROR(165," ⊗ is undefined in this expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
END;
GET_TOKEN;
β;
[MISC_RES]
IF EQU(TOKEN,"INSCALAR")
THEN α
$$1←MK_EXPR("($SCALRD)",SCALAR_VALUE, NIL_DIMENS);
GET_TOKEN;
β
ELSE IF EQU(TOKEN,"QUERY")
THEN α
STRING S;
S←"($QUERY ";
GET_TOKEN;
IF TOKEN≠"(" THEN ERROR_REJECT(161,"need ( after QUERY");
DO α
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN THEN
α S←S&dquote&TOKEN&dquote&" "; GET_TOKEN; β
ELSE α $$1←EXP;
S←S&EXPR:BODY[$$1]&" ";
β;
IF TOKEN≠"," AND TOKEN ≠")" THEN
ERROR(162,"need , between arguments of QUERY");
β UNTIL TOKEN=")";
S←S&")";
$$1←MK_EXPR(S,SCALAR_VALUE, NIL_DIMENS);
GET_TOKEN;
β
ELSE α ERROR(160,"UNEXPECTED TOKEN FOUND IN MISC_RES :"&TOKEN);
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β;
ELSE α ERROR(170,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will return null expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β
β;
ELSE α ERROR(180,"UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃, continue will give null expression");
$$1←MK_EXPR(NULL,0,NULL_RECORD);
β
β
β;
RETURN($$1);
β;
! exp2 starts here, p_exp_basic;
GET_TOKEN;
OUTEXPR←EXPR:BODY[$$1←EXP];
REJECT←TRUE;EXP_TYPE←EXPR:TYPE[$$1];
EXP_DIMENS←EXPR:DIMEN[$$1];
RETURN(TRUE);
DONEP:RETURN(FALSE);
β;
BOOLEAN PROCEDURE P_EXP_BASIC;
α
BOOLEAN B1;
IF (B1←P_EXP2_BASIC)=TRUE THEN PRINT(OUTEXPR);
RETURN(B1);
β;
RECORD_CLASS CONDITION(INTEGER TYPE,COND; STRING SEXP);
DEFINE NEITHER_TYPE=0,
EQUALITY_TYPE=1,
RELATIONAL_TYPE=2;
DEFINE FT_COND=2; ! for forces and torques;
DEFINE DURATION_COND=5,
APPROACH_COND=6,
DEPARTURE_COND=7,
SPEED_FACTOR_COND=8,
FORCE_FRAME_COND=9,
NULLING_COND=10,
NO_NULLING_COND=11,
STIFFNESS_COND=12,
DRIVER_TURNS_COND=13,
RTMOVE_COND=14,
WOBBLE_COND=15,
STOP_WAIT_TIME_COND=16,
ANGULAR_VELOCITY_COND=17,
FAILURE_COND=18,
EXPRESSION_COND=19,
EVENT_COND=20,
SETBASE_COND=21,
GATHER_COND=22;
RPTR(CONDITION)PROCEDURE GET_CONDITION(STRING DEVICE);
BEGIN "get_condition"
LABEL DONEP;
PROCEDURE F_STATE(VALUE INTEGER IP; STRING SP);
α ERROR(IP,SP&CRLF&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GOTO DONEP;
β;
PROCEDURE P_EXP2; IF P_EXP2_BASIC=FALSE THEN GOTO DONEP;
PROCEDURE P_EXP; IF P_EXP_BASIC=FALSE THEN GOTO DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
return(r1);
β;
PROCEDURE VALID_DEVICE(STRING DEV1,DEV2(NULL),DEV3(NULL));
α
STRING S;
FOR S←DEV1,DEV2,DEV3 DO
IF EQU(DEVICE,S) THEN RETURN;
F_STATE(230,"Invalid clause for "&DEVICE);
β;
RCLASS ID_PROP( STRING STOKEN; INTEGER TYPE,id_CLASS; RANY TPTR);
RPTR(ID_PROP)PROCEDURE GET_ID;
BEGIN
RPTR(ID_PROP)IDX;
GET_TOKEN;
IF TYPE_OF_TOKEN = ID_TOKEN THEN
α IDX←NEW_RECORD(ID_PROP);
ID_PROP:STOKEN[IDX]←TOKEN;
ID_PROP:TYPE[IDX]←ID_TOKEN;
ID_PROP:ID_CLASS[IDX]←ID_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
β
ELSE
IF TYPE_OF_TOKEN = ARRAY_TOKEN THEN
α
IDX←NEW_RECORD(ID_PROP);
ID_PROP:TYPE[IDX]←ARRAY_TOKEN;
ID_PROP:ID_CLASS[IDX]←ARRAY_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
REJECT←TRUE;
P_EXP2;
ID_PROP:STOKEN[IDX]←OUTEXPR;
β
ELSE ERROR(12,"need either simple or array identifier here");
RETURN(IDX);
END;
! relation,scalar_relational,mk_condition,deproach_proc;
INTEGER PROCEDURE RELATION(STRING S; REFERENCE STRING CODE);
BEGIN
! checks that S is a relational operator and massages CODE to take the
right value;
IF LENGTH(S)≠1 THEN
BEGIN ERROR(1000,"Need ≥,<, or = here");
RETURN(NEITHER_TYPE);
END;
IF S="=" THEN BEGIN CODE←"="; RETURN(EQUALITY_TYPE) END
ELSE IF S=">" THEN
BEGIN
ERROR(1000,"> is invalid here, will convert to ≥");
CODE←"≥";
END
ELSE IF S="≤" THEN
BEGIN
ERROR(1000,"≤ is invalid here, will convert to <");
CODE←"<";
END
ELSE IF S="≥" OR S="<" THEN CODE←S;
RETURN(RELATIONAL_TYPE);
END;
RPTR(CONDITION)PROCEDURE MK_CONDITION(STRING SEXP;
INTEGER COND,TYPE(NEITHER_TYPE));
BEGIN ! generates a new record with the appropriate fields;
RPTR(CONDITION)C;
C←NEW_RECORD(CONDITION);
CONDITION:COND[C]←COND;
CONDITION:TYPE[C]←TYPE;
CONDITION:SEXP[C]←SEXP;
RETURN(C);
END;
RPTR(CONDITION)PROCEDURE SCALAR_RELATIONAL(STRING CALLING_STRING,SCOND;
INTEGER COND; RPTR(DIMENS_EXPONENT)DIM;STRING EXTRA(NULL);
BOOLEAN NOPRINT(FALSE));
BEGIN ! handles conditions of the form <condition> <rel> <scalar exp>
! EXTRA is used for the - or + for the magnitude or signed value for forces;
! NOPRINT is used to indicate whether or not to print out the relations ;
RPTR(CONDITION)C; INTEGER TYPE;
STRING CODE,S;
GET_TOKEN;
TYPE←RELATION(TOKEN,CODE);
P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DIM,CALLING_STRING)
THEN F_STATE(3000,"Need a scalar expression here for "&calling_string);
IF SCOND=DURATION_COND AND CODE="≥" THEN CODE←">";
IF NOPRINT THEN S←SCOND&" "&OUTEXPR ELSE
S←SCOND&" "&CODE&" "&EXTRA&" "&OUTEXPR;
RETURN(MK_CONDITION(S,COND,TYPE));
END;
RPTR(CONDITION)PROCEDURE SCALAR_EQUALITY(STRING CALLING_STRING,SCOND;
INTEGER COND; RPTR(DIMENS_EXPONENT)DIM);
BEGIN ! handles conditions of the form <condition> = <scalar exp>
! NOPRINT is used to indicate whether or not to print out the equlaity ;
RPTR(CONDITION)C; INTEGER TYPE;
STRING CODE,S;
GET_TOKEN;
TYPE←RELATION(TOKEN,CODE);
IF CODE≠"=" THEN F_STATE(3001,"Need equality sign here");
P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DIM,CALLING_STRING)
THEN F_STATE(3000,"Need a scalar expression here for "&calling_string);
S←SCOND&" "&OUTEXPR;
RETURN(MK_CONDITION(S,COND,TYPE));
END;
RPTR(CONDITION)PROCEDURE DEPROACH_PROC(STRING CALLING_STRING,SEXP;
INTEGER COND);
BEGIN
INTEGER TYPE; STRING S;
GET_TOKEN;
IF TOKEN≠"=" THEN ERROR(1002,"Need = for "&CALLING_STRING);
S←SEXP&" ";
GET_TOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN
S←S&TOKEN
ELSE IF EQU(TOKEN,"DEPROACH") THEN
BEGIN "deproach"
S←S&"($DEPR ";
SPACING←SPACING+1;
GET_TOKEN;
IF TOKEN≠"(" THEN ERROR_REJECT(3019,"Need left paren here");
P_EXP2;
IF NOT CHECK_EXP_TYPE_DIMENS(frame_exp_value,DISTANCE_DIMENS,
"FRAME expression")
then F_STATE(3020,"Need frame expression here");
GET_TOKEN;
IF TOKEN≠")" THEN ERROR_REJECT(3021,"Need right paren here");
S←S&OUTEXPR;
SPACING←SPACING-1;
S←S&")";
END "deproach"
ELSE BEGIN "general case"
REJECT←TRUE;
SPACING←SPACING+1;
P_EXP2;
IF EXP_TYPE≠SCALAR_VALUE AND EXP_TYPE≠VECTOR_VALUE AND EXP_TYPE≠TRANS_VALUE
THEN ERROR(3018,"Type mismatch for "&CALLING_STRING);
CHECK_DIMENSIONS_PROG(CALLING_STRING,EXP_DIMENS,DISTANCE_DIMENS);
S←S&OUTEXPR;
SPACING←SPACING-1;
END "general case";
RETURN(MK_CONDITION(S,COND));
END;
! force_frame_proc,ft_proc;
RPTR(CONDITION)PROCEDURE FORCE_FRAME_PROC(STRING CALLING_STRING);
BEGIN
STRING S;
P_EXP2;
IF EXP_TYPE≠rot_value AND EXP_TYPE≠trans_value THEN
F_STATE(1202,"Need rot or trans expression in "&CALLING_STRING);
S←"$FORCE_FRAME "&OUTEXPR;
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN
BEGIN "in" GET_TOKEN;
IF TOKEN_EQU("HAND","BHAND","YHAND","MOVING")
THEN S←S&" ⊗"
ELSE IF TOKEN_EQU("WORLD","STATION","FIXED")
THEN S←S& " #";
GET_TOKEN;
IF NOT TOKEN_EQU("COORD","COORDS","COORDINATES")
THEN REJECT←TRUE;
END "in"
ELSE BEGIN
REJECT←TRUE;
S←S&" #"; ! default is station coord ;
END;
RETURN(MK_CONDITION(S,FORCE_FRAME_COND));
END;
RPTR(CONDITION)PROCEDURE FT_PROC(STRING DISCRIMINATOR,MAG);
BEGIN "ft_cond" ! handles force/torque conditions;
! discriminator="+"/"-" for force/torque
mag="+"/"-" for magnitude or signed force/torque;
RPTR(CONDITION)CPTR;
RPTR(DIMENS_EXPONENT)D;
STRING ALONG_ABOUT;
STRING VEXP; ! for the direction expression ;
IF DISCRIMINATOR="+" THEN
BEGIN D←FORCE_DIMENS;
ALONG_ABOUT←"ALONG";
VALID_DEVICE("ARM","ON");
END
ELSE BEGIN D←TORQUE_DIMENS;
ALONG_ABOUT←"ABOUT";
VALID_DEVICE("ARM","DRIVER","ON");
END;
GET_TOKEN;
IF TOKEN="(" THEN
BEGIN "specific torque/force"
IF EQU(DEVICE,"DRIVER") THEN F_STATE(231,"driver torque cannot take direction information");
P_EXP2;
IF EXP_TYPE≠VECTOR_VALUE THEN ERROR(3000,"Need VECTOR value here");
VEXP←OUTEXPR;
GET_TOKEN;
IF TOKEN≠")" THEN ERROR_REJECT(3000,"Need right paren here");
IF MAG="+" THEN
BEGIN GET_TOKEN;
IF TOKEN≠"|" THEN ERROR_REJECT(3001,"Need | here");
END;
CPTR←SCALAR_RELATIONAL("FORCE/TORQUE",NULL,FT_COND,D,MAG);
END "specific torque/force"
ELSE BEGIN "general torque/force"
IF MAG="+" THEN
BEGIN
IF TOKEN≠"|" THEN ERROR_REJECT(3001,"Need | here");
END ELSE REJECT←TRUE;
CPTR←SCALAR_RELATIONAL("FORCE CONDITION",NULL,FT_COND,D,MAG);
IF NOT EQU(DEVICE,"DRIVER") THEN
BEGIN
GET_TOKEN;
IF NOT EQU(TOKEN,ALONG_ABOUT) THEN
ERROR(1003,"Need "&ALONG_ABOUT&" here");
P_EXP2;
IF EXP_TYPE≠VECTOR_VALUE
THEN ERROR(1004,"Need VECTOR value for direction");
VEXP←OUTEXPR;
END
ELSE VEXP←"()";
END"general torque/force";
GET_TOKEN;
CONDITION:SEXP[CPTR]←"$FORCE "&VEXP&" "
&CONDITION:SEXP[CPTR]&" "&DISCRIMINATOR&" ";
IF EQU(TOKEN,"OF") THEN
BEGIN RPTR(CONDITION)CPTR2;
CPTR2←FORCE_FRAME_PROC("FORCE/TORQUE CONDITION");
CONDITION:SEXP[CPTR]←CONDITION:SEXP[CPTR]&"("&
CONDITION:SEXP[CPTR2]&")";
END
ELSE REJECT←TRUE;
RETURN(CPTR);
END "ft_cond";
! stiffness_cond;
RPTR(CONDITION)PROCEDURE STIFFNESS_PROC;
BEGIN "stiffness_proc"
STRING ARRAY S[1:6]; INTEGER ARRAY TYPE[1:6]; STRING SEXP;
RPTR(DIMENS_EXPONENT)ARRAY D[1:6]; INTEGER I;
I←0; SEXP←"$STIFFNESS ";
IF NOT EQU(CURRENT_DEVICE,"ARM")
THEN F_STATE(1006,"STIFFNESS valid only for MOVE");
GET_TOKEN; IF TOKEN≠"=" THEN ERROR(1007,"Need = here");
GET_TOKEN; IF TOKEN≠"(" THEN ERROR(1009,"Need ) here");
DO BEGIN
P_EXP2; S[I←I+1]←OUTEXPR;
TYPE[I]←EXP_TYPE; D[I]←EXP_DIMENS;
GET_TOKEN;
END UNTIL (I=6) OR(TOKEN≠",");
IF TOKEN≠")" THEN ERROR(1010,"Need ) after argument list for STIFFNESS");
IF I=6 THEN
α "6 scalars"
INTEGER J;
FOR J←1 STEP 1 UNTIL 6 DO
IF TYPE[J]≠SCALAR_VALUE THEN ERROR(1012,"Need scalar arguments here");
FOR J←1 STEP 1 UNTIL 3 DO
CHECK_DIMENSIONS_PROG("argument "&CVS(J)&" of SETSTIFF",D[J],
DIVIDE_DIMENSIONS(FORCE_DIMENS,DISTANCE_DIMENS));
FOR J←4 STEP 1 UNTIL 6 DO
CHECK_DIMENSIONS_PROG("argument "&CVS(J)&" of SETSTIFF",D[J],
DIVIDE_DIMENSIONS(TORQUE_DIMENS,ANGLE_DIMENS));
SEXP←SEXP&"($VMAKE "&S[1]&" "&S[2]&" "&S[3]&")";
SEXP←SEXP&"($VMAKE "&S[4]&" "&S[5]&" "&S[6]&")";
β "6 scalars"
ELSE IF I=2 THEN
α "2 vectors"
INTEGER J;
FOR J←1 STEP 1 UNTIL 2 DO
IF TYPE[J]≠VECTOR_VALUE
THEN F_STATE(1013,"Need vector arguments here");
CHECK_DIMENSIONS_PROG("first vector argument of STIFFNESS",
D[1],DIVIDE_DIMENSIONS(FORCE_DIMENS,DISTANCE_DIMENS));
CHECK_DIMENSIONS_PROG("second vector argument of STIFFNESS",
D[2],DIVIDE_DIMENSIONS(TORQUE_DIMENS,ANGLE_DIMENS));
SEXP←SEXP&" "&S[1]&" "&S[2];
β "2 vectors"
ELSE ERROR(1030,"SETSTIFF: incompatible number of arguments");
GET_TOKEN;
IF EQU(TOKEN,"ABOUT") THEN
SEXP←SEXP&"("&CONDITION:SEXP[FORCE_FRAME_PROC("STIFFNESS clause")]&")"
ELSE BEGIN REJECT←TRUE;
SEXP←SEXP&" ($FORCE_FRAME NILTRANS ⊗)";
END;
RETURN(MK_CONDITION(SEXP,STIFFNESS_COND));
END "stiffness_proc";
RPTR(CONDITION)PROCEDURE GATHERPROC;
BEGIN "gatherproc"
STRING SEXP,S; INTEGER I;
SEXP←"$GATHER ";
IF NOT EQU(CURRENT_DEVICE,"ARM")
THEN F_STATE(1006,"GATHER valid only for MOVE");
GET_TOKEN; IF TOKEN≠"=" THEN ERROR(1007,"Need = here");
GET_TOKEN; IF TOKEN≠"(" THEN ERROR(1009,"Need ) here");
DO BEGIN
GET_TOKEN; I←0;
FOR S← "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL"
DO IF EQU(TOKEN,S) THEN DONE ELSE I←I+1;
IF I=14 THEN ERROR(1011,TOKEN&" is not a valid term in GATHER clause");
SEXP←SEXP & TOKEN& " ";
GET_TOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR(1010,"Need ) here");
RETURN(MK_CONDITION(SEXP,STIFFNESS_COND));
END "gatherproc";
! get_condition begins here;
RPTR(CONDITION)CPTR;
GET_TOKEN;
IF EQU(TOKEN,"FORCE") THEN
CPTR←FT_PROC("+","-")
ELSE IF EQU(TOKEN,"TORQUE") THEN
CPTR←FT_PROC("-","-")
ELSE IF EQU(TOKEN,"|") THEN
BEGIN "magnitude"
GET_TOKEN;
IF EQU(TOKEN,"FORCE") THEN CPTR←FT_PROC("+","+")
ELSE IF EQU(TOKEN,"TORQUE") THEN CPTR←FT_PROC("-","+")
ELSE ERROR(1000,"Must have FORCE or TORQUE after |");
END "magnitude"
ELSE IF EQU(TOKEN,"DURATION") THEN
CPTR←SCALAR_RELATIONAL("DURATION","$DURATION",DURATION_COND,
TIME_DIMENS)
ELSE IF EQU(TOKEN,"APPROACH") THEN
CPTR←DEPROACH_PROC("APPROACH","$ARRIVAL",APPROACH_COND)
ELSE IF EQU(TOKEN,"DEPARTURE") THEN
CPTR←DEPROACH_PROC("DEPARTURE","$DEPARTURE",DEPARTURE_COND)
ELSE IF EQU(TOKEN,"SPEED_FACTOR") THEN
CPTR←SCALAR_EQUALITY("SPEED_FACTOR","$SPEED_FACTOR",SPEED_FACTOR_COND,
NIL_DIMENS)
ELSE IF EQU(TOKEN,"FORCE_FRAME") THEN
BEGIN "force_frame"
GET_TOKEN;
IF TOKEN≠"=" THEN ERROR_REJECT(1004,"Need = in FORCE_FRAME clause");
CPTR←FORCE_FRAME_PROC("FORCE_FRAME CLAUSE");
END "force_frame"
ELSE IF EQU(TOKEN,"NULLING") THEN
CPTR←MK_CONDITION("$NNULL -",NULLING_COND)
ELSE IF EQU(TOKEN,"NO_NULLING") THEN
CPTR←MK_CONDITION("$NNULL +",NO_NULLING_COND)
ELSE IF EQU(TOKEN,"STIFFNESS") THEN
CPTR←STIFFNESS_PROC
ELSE IF EQU(TOKEN,"RTMOVE") THEN
CPTR←MK_CONDITION("$RTMOVE",RTMOVE_COND)
ELSE IF EQU(TOKEN,"WOBBLE") THEN
CPTR←SCALAR_EQUALITY("WOBBLE","$WOBBLE",WOBBLE_COND,ANGLE_DIMENS)
ELSE IF EQU(TOKEN,"STOP_WAIT_TIME") THEN
CPTR←SCALAR_EQUALITY("STOP_WAIT_TIME","$SW_TIME",STOP_WAIT_TIME_COND,
TIME_DIMENS)
ELSE IF EQU(TOKEN,"ANGULAR_VELOCITY") THEN
BEGIN
VALID_DEVICE("DRIVER");
CPTR←SCALAR_EQUALITY("ANGULAR_VELOCITY","$VELOCITY",
ANGULAR_VELOCITY_COND,ANGULAR_VELOCITY_DIMENS)
END
ELSE IF EQU(TOKEN,"ERROR") THEN
BEGIN
CPTR←SCALAR_EQUALITY("ERROR","$ERROR",FAILURE_COND,NIL_DIMENS);
CONDITION:TYPE[CPTR]←RELATIONAL_TYPE;
END
ELSE IF EQU(TOKEN,"GATHER") THEN
BEGIN
CPTR←GATHERPROC;
CONDITION:TYPE[CPTR]←EQUALITY_TYPE;
END
ELSE IF EQU(TOKEN,"FORCE_WRIST") THEN
BEGIN BOOLEAN NEG; STRING S;
NEG←FALSE;
GET_TOKEN;
IF EQU(TOKEN,"NOT") THEN BEGIN NEG←TRUE; GET_TOKEN; END;
IF NOT EQU(TOKEN,"ZEROED") THEN ERROR(1000,"Need ZEROED here");
IF NEG THEN S←"$SETBASE -" ELSE S←"$SETBASE +";
CPTR←MK_CONDITION(S,SETBASE_COND,EQUALITY_TYPE);
END
ELSE IF ((TYPE_OF_TOKEN=ID_TOKEN) AND (ID_TYPE=EVENT_VALUE))
OR ((TYPE_OF_TOKEN=ARRAY_TOKEN) AND (ARRAY_TYPE=EVENT_VALUE)) THEN
BEGIN
RPTR(ID_PROP)IX;
REJECT←TRUE;
IF (IX←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IX]≠EVENT_VALUE
THEN F_STATE(1300,"Need EVENT ID here.");
CPTR←MK_CONDITION(ID_PROP:STOKEN[IX],EVENT_COND,RELATIONAL_TYPE);
END
ELSE BEGIN "exp"
REJECT←TRUE;
P_EXP2;
IF EXP_TYPE≠BOOLE_VALUE AND EXP_TYPE≠SCALAR_VALUE THEN
F_STATE(1005,"Need a scalar expression here");
CPTR←MK_CONDITION(OUTEXPR,EXPRESSION_COND,RELATIONAL_TYPE);
END "exp";
RETURN(CPTR);
DONEP:RETURN(NULL_RECORD);
END"get_condition";
! P_clauses, T_gen;
BOOLEAN recursive PROCEDURE P_CLAUSES_BASIC(STRING DEVICE);
α "P_CLAUSES"
BOOLEAN T; LABEL FLUSH; BOOLEAN ICMT;STRING LABL; INTEGER LAB_TYPE;
LABEL DONEP; STRING CURDEV;
PROCEDURE P_EXP; IF P_EXP_BASIC=FALSE THEN GOTO DONEP;
PROCEDURE P_EXP2; IF P_EXP2_BASIC=FALSE THEN GOTO DONEP;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP;β;
RETURN(R1);
β;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO DONEP; β;
return(r1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO DONEP; β;
RETURN(B1);
β;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
ICMT←INSIDE_CONDITION_MONITOR;
T←TRUE; GET_TOKEN;
CURDEV←CURRENT_DEVICE;
WHILE T DO
α
LABL←NULL;
IF (LAB_TYPE←ID_TYPE)=LABEL_VALUE
THEN IF DEFINED(TOKEN_PTR)
THEN ERROR(123,TOKEN& " already used.")
ELSE
α DEFIN(TOKEN_PTR); LABL←TOKEN&" ";
INSIDE_CONDITION_MONITOR←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN ERROR(23,"Need colon after label " & LABL & " .") ELSE GET_TOKEN;
β;
IF (TYPE_OF_RES_WORD=on_RES)
THEN
α RPTR(CONDITION)PTR;
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN PRINT("( "&LABL& "$ON +")
ELSE α CHECK_NEXT_TOKEN(37, NULL,"ON");
PRINT("( " & LABL& "$ON -"); β;
SPACING←SPACING+1;
PTR←GET_CONDITION(DEVICE);
IF PTR=NULL_RECORD THEN F_STATE(1000,"Invalid condition in CM");
IF CONDITION:TYPE[PTR]≠RELATIONAL_TYPE THEN
ERROR(1000,"Need non-quality condition for condition monitor");
IF CONDITION:COND[PTR]=EXPRESSION_COND OR CONDITION:COND[PTR]=EVENT_COND
THEN PRINT(CONDITION:SEXP[PTR])
ELSE BEGIN
PRINT("(");
PRINT(CONDITION:SEXP[PTR]);
PRINT(")");
END;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β
ELSE IF EQU(TOKEN,"(") THEN
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1; TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="("
THEN C←C+1
ELSE IF BRCHAR=")"
THEN C←C-1
ELSE α PRINT(TEMP); TEMP←NULL; β;
β;
PRINT(TEMP); GET_TOKEN;
β
ELSE IF ¬(move_beg ≤ TYPE_OF_RES_WORD ≤ move_end) THEN
α
! END OF MOVE STATEMENT FOUND;
REJECT←TRUE; T←FALSE;
β
ELSE CASE TYPE_OF_RES_WORD - move_beg OF
α
[to_X] IF NOT EQU(CURDEV,"ARM") THEN
ERROR(1000,"TO can be used only in a MOVE statement")
ELSE α ! dessttination found ;
PRINT("($TO ");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(trans_VALUE,DISTANCE_DIMENS, "FRAME Expression")
THEN ERROR_REJECT(20,"Need either a FRAME or TRANSFORM expression here.");
PRINT(")"); GET_TOKEN;
β;
[via_X] IF NOT EQU(CURDEV,"ARM") THEN
ERROR(1000,"VIA can be used only in a MOVE statement")
ELSE α ! VIA CLAUSE FOUND;
PRINT("($VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
GET_TOKEN;
IF EQU(TOKEN,",") THEN
α SPACING←SPACING-1; PRINT(")");
WHILE EQU(TOKEN,",") DO
α
PRINT("($VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β;
β
ELSE α BOOLEAN V_FOUND,D_FOUND,CONTIN; CONTIN←TRUE;
IF EQU(TOKEN,"WHERE") THEN
WHILE ¬(V_FOUND ∧ D_FOUND) ∧ CONTIN DO
α
GET_TOKEN;
IF V_FOUND ∧ EQU(TOKEN,"VELOCITY") THEN
F_STATE(3011,"Multiple VELOCITY specification found in WITH clause.")
ELSE IF EQU(TOKEN,"VELOCITY") THEN
α PRINT("($VELOCITY "); GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3014,"Need = here.");
SPACING←SPACING+1; P_EXP;
SPACING←SPACING-1; PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(vector_VALUE,VELOCITY_DIMENS,
"Velocity expression") THEN
α
SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a vector expression here.");
β;
V_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE IF D_FOUND ∧ EQU(TOKEN,"DURATION") THEN
F_STATE(3013,"Multiple DURATION specification found in WITH clause.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α STRING S;
GET_TOKEN;
IF EQU(TOKEN,"=") THEN S←TOKEN
ELSE IF EQU(TOKEN,"≤") OR EQU(TOKEN,"<")
THEN S←"<"
ELSE IF EQU(TOKEN,"≥") OR EQU(TOKEN,">")
THEN S←">"
ELSE ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("($DURATION " & S & " ");
SPACING←SPACING+1;P_EXP;SPACING←SPACING-1;
PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE, TIME_DIMENS,
"DUARATION clause")THEN
α SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a scalar expression here.");
β;
D_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE CONTIN←FALSE;
β;
IF EQU(TOKEN,"THEN") THEN
α SPACING←SPACING+1; P_STATEMENT; SPACING←SPACING-1;
GET_TOKEN;
β;
SPACING←SPACING-1; PRINT(")");
β;
β;
[directly_X] α
PRINT ("($ARRIVAL NILDEPROACH)");
PRINT ("($DEPARTURE NILDEPROACH)");get_token;
β;
ELSE α REJECT←TRUE; T←FALSE; β;
[with_X] α
RPTR(CONDITION)PTR;
PRINT("(");
SPACING←SPACING+1;
IF (PTR←GET_CONDITION(DEVICE))=NULL_RECORD THEN
F_STATE(1000,"Invalid condition found");
IF CONDITION:TYPE[PTR]=RELATIONAL_TYPE AND
CONDITION:COND[PTR]≠DURATION_COND THEN
ERROR(1000,"Need equality condition for CLAUSE");
PRINT(CONDITION:SEXP[PTR]);
GET_TOKEN;
IF EQU(TOKEN,"THEN") AND (CONDITION:COND[PTR]=APPROACH_COND
OR CONDITION:COND[PTR]=DEPARTURE_COND)
THEN BEGIN SPACING←SPACING+1;
P_STATEMENT;
SPACING←SPACING-1;
GET_TOKEN;
END;
SPACING←SPACING-1;
PRINT(")");
β
β;
if id_type=label_value then t←true; ! patched;
β;
FLUSH: INSIDE_CONDITION_MONITOR←ICMT; RETURN(TRUE);
DONEP: RETURN(FALSE);
β "P_CLAUSES";
STRING PROCEDURE T_GEN;
α
T_COUNT←T_COUNT+1;
RETURN("_T"&CVS(T_COUNT));
β;
! P_statement, F_state, modify_continue, modify_flush;
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
LABEL GLOBAL_RE_TRY;
LABEL FLUSH,TRY_AGAIN; STRING LABL; INTEGER LABEL_TYPE;
RPTR(DIMENS_EXPONENT) DIM_PTR;
rptr(any_class) PROCEDURE ERROR(INTEGER I; STRING S);
α rptr(any_class) r1;
GLOBAL_BACKUP←TRUE; r1←ERROR_BASIC(I,S);
IF GLOBAL_MODIFIED = TRUE THEN α GET_TOKEN; GLOBAL_MODIFIED←FALSE;
GOTO GLOBAL_RE_TRY; β;
return(r1);
β;
RPTR(DIMENS_EXPONENT)
procedure CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR (DIMENS_EXPONENT) R1;
R1←CHECK_DIMENSIONS_PROG(S, D1,D2);
IF GLOBAL_MODIFIED=TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO GLOBAL_RE_TRY; β;
RETURN(R1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α BOOLEAN B1; B1←CHECK_EXP_TYPE_DIMENS_PROG(DESIRED_EXP_TYPE, PTR, ERROR_MESS);
IF GLOBAL_MODIFIED =TRUE THEN α GLOBAL_MODIFIED←FALSE; GOTO GLOBAL_RE_TRY; β;
RETURN(B1);
β;
PROCEDURE P_EXP;
IF P_EXP_BASIC=FALSE THEN GOTO GLOBAL_RE_TRY;
PROCEDURE P_EXP2;
IF P_EXP2_BASIC=FALSE THEN GOTO GLOBAL_RE_TRY;
RCLASS ID_PROP( STRING STOKEN; INTEGER TYPE,id_CLASS; RANY TPTR);
RPTR(ID_PROP)PROCEDURE GET_ID;
BEGIN
RPTR(ID_PROP)IDX;
GET_TOKEN;
IF TYPE_OF_TOKEN = ID_TOKEN THEN
α IDX←NEW_RECORD(ID_PROP);
ID_PROP:STOKEN[IDX]←TOKEN;
ID_PROP:TYPE[IDX]←ID_TOKEN;
ID_PROP:ID_CLASS[IDX]←ID_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
β
ELSE
IF TYPE_OF_TOKEN = ARRAY_TOKEN THEN
α
IDX←NEW_RECORD(ID_PROP);
ID_PROP:TYPE[IDX]←ARRAY_TOKEN;
ID_PROP:ID_CLASS[IDX]←ARRAY_TYPE;
ID_PROP:TPTR[IDX]←TOKEN_PTR;
REJECT←TRUE;
P_EXP2;
ID_PROP:STOKEN[IDX]←OUTEXPR;
β
ELSE ERROR(12,"need either simple or array identifier here");
RETURN(IDX);
END;
PROCEDURE P_CLAUSES(STRING DEVICE);
IF P_CLAUSES_BASIC(DEVICE)=FALSE THEN GOTO GLOBAL_RE_TRY;
PROCEDURE F_STATE(VALUE INTEGER PP,IP(-10000); VALUE STRING SP(NULL));
α STRING CLOSE; INTEGER I; CLOSE←NULL;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
IF SP≠NULL THEN ERROR(IP,SP&crlf&"Continue will flush statement.")
else outstr(CRLF&"STATEMENT WILL BE FLUSHED"&CRLF);
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
BOOLEAN PROCEDURE MODIFY_CONTINUE(INTEGER ERR_NO; STRING MESS);
α ERROR(ERR_NO,MESS);
return(false);
β;
BOOLEAN PROCEDURE MODIFY_FLUSH(INTEGER PP,ERR_NO; STRING MESS);
α F_STATE(PP,ERR_NO,MESS);
return(false);
β;
REQUIRE "[][]" DELIMITERS;
! begin_P,end_P, open_paren_P;
recursive procedure begin_P;
α INTEGER SAVE_DEC_NUM,SAVE_MACRO_DEC_NUM,SAVE_DIMEN_DEC_NUM;
INTEGER SAVE_ARRAY_DEC_NUM,SAVE_PROCEDURE_DEC_NUM;
record_pointer(any_class) rr;
STRING B1,B2,E1,E2,TT; STRING S, BLK_NAME, BLK_NAME_END;
STRING UNUSED_S;
IFC DEFIN_PRINT_SWITCH THENC STRING UNDEFINED_S;ENDC
TT←"("&LABL;
B1←B2←"BEGIN";
E1←E2←"END";
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
SAVE_ARRAY_DEC_NUM←ARRAY_DEC_NUM; ARRAY_DEC_NUM←0;
SAVE_PROCEDURE_DEC_NUM←PROCEDURE_DEC_NUM; PROCEDURE_DEC_NUM←0;
SAVE_MACRO_DEC_NUM←MACRO_DEC_NUM; MACRO_DEC_NUM←0;
SAVE_DIMEN_DEC_NUM←DIMEN_DEC_NUM; DIMEN_DEC_NUM←0;
IF EQU(TOKEN,"BEGIN") THEN
α B2←"CO"&B2;E2←"CO"&E2;TT←TT&"$BL";β
ELSE α B1←"CO"&B1;E1←"CO"&E1;TT←TT&"$CO";β;
PRINT(TT);
printout;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN α BLK_NAME←TOKEN; printout β
ELSE α BLK_NAME←NULL; REJECT←TRUE; β;
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,E1) DO
α
P_STATEMENT;
if reject=false then GET_TOKEN ELSE REJECT←false;
IF TYPE_OF_RES_WORD≠end_RES
THEN ERROR_REJECT(4,
"Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,E2) THEN
α
ERROR(5,"Block ends with " & E2 & cr
& "Continue will view as "& E1);
TOKEN←E1;
β;
PRINTOUT;
β;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN BLK_NAME_END←TOKEN
ELSE α BLK_NAME_END←NULL; REJECT←TRUE;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
if token=";" then out(channew,";");
endc
β;
IF ¬(EQU(BLK_NAME,BLK_NAME_END) OR EQU(BLK_NAME_END,NULL))
THEN ERROR(600, "Block name at end does not agree with that at beginning.");
UNUSED_S←NULL;
IFC DEFIN_PRINT_SWITCH THENC UNDEFINED_S←NULL; ENDC;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α STRING SS;
SYMBOL_TABLE[HASH(SS←ID_LIST:NAME[TOP_ID],id_hasher)]
← ID_LIST:NEXT[TOP_ID];
IF ¬USED(TOP_ID) THEN UNUSED_S←UNUSED_S&CRLF& "⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
IFC DEFIN_PRINT_SWITCH THENC
IF ¬DEFINED(TOP_ID) THEN UNDEFINED_S←UNDEFINED_S&CRLF&"⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
ENDC
TOP_ID←ID_LIST:LAST[RR←TOP_ID];
β;
IF LENGTH(UNUSED_S)≠0 THEN UNUSED_S←UNUSED_S&
CRLF & " WERE NEVER USED";
IFC DEFIN_PRINT_SWITCH THENC
IF LENGTH(UNDEFINED_S)≠0 THEN UNUSED_S←UNUSED_S&CRLF & UNDEFINED_S &
CRLF & " WERE NEVER DEFINED";
ENDC
IF LENGTH(UNUSED_S)≠0 THEN ERROR(-1,UNUSED_S);
FOR I←1 STEP 1 UNTIL MACRO_DEC_NUM DO
α
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_MACRO],macro_hasher)]
←MACRO_LIST:NEXT[TOP_MACRO];
TOP_MACRO←MACRO_LIST:LAST[RR←TOP_MACRO];
β;
FOR I←1 STEP 1 UNTIL DIMEN_DEC_NUM DO
α
DIMENS_TABLE[HASH(DIMENS_EXPONENT:NAME[TOP_DIMENS],metric_hasher)]
←DIMENS_EXPONENT:NEXT[TOP_DIMENS];
TOP_DIMENS←DIMENS_EXPONENT:LAST[rr←TOP_DIMENS];
β;
FOR I←1 STEP 1 UNTIL ARRAY_DEC_NUM DO
α
ARRAY_SYMBOL_TABLE[HASH(ARRAY_LIST:NAME[TOP_ARRAY],array_hasher)]
←array_list:NEXT[TOP_array];
TOP_array←array_list:LAST[rr←TOP_array];
β;
FOR I←1 STEP 1 UNTIL procedure_DEC_NUM DO
α
procedure_SYMBOL_TABLE[HASH(procedure_LIST:NAME[TOP_procedure],procedure_hasher)]
←procedure_list:NEXT[TOP_procedure];
TOP_procedure←procedure_list:LAST[rr←TOP_procedure];
β;
DEC_NUM←SAVE_DEC_NUM;
MACRO_DEC_NUM←SAVE_MACRO_DEC_NUM;
ARRAY_DEC_NUM←SAVE_ARRAY_DEC_NUM;
PROCEDURE_DEC_NUM←SAVE_PROCEDURE_DEC_NUM;
DIMEN_DEC_NUM←SAVE_DIMEN_DEC_NUM;
PRINT(")");
PRINTOUT;
β;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
IF TOKEN=";" THEN print("()");
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
PRINTOUT;
β;
! if_P, plan_P, while_P;
procedure if_P;
α ! IF STATEMENT FOUND;
IF PLAN_STATEMENT THEN PRINT("("&LABL&"$CIF") ELSE PRINT("("&LABL&"$IF");
PLAN_STATEMENT←FALSE;
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(1,10,"Conditional for IF must be boolean");
GET_TOKEN;
IF ¬EQU(TOKEN,"THEN") THEN
ERROR_REJECT(9,"Missing THEN. Continue will insert it.");
P_STATEMENT;
GET_TOKEN;
IF EQU(TOKEN,"ELSE") THEN P_STATEMENT ELSE REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
procedure plan_P;
α ! PLAN STATEMENT FOUND;
GET_TOKEN;
IF ¬(EQU(TOKEN,"IF") OR EQU(TOKEN,"WRITE") OR EQU(TOKEN,"ERROR")
OR EQU(TOKEN,"FOREACH")) THEN MODIFY_FLUSH(0,11,"Illegal token to "&
"follow PLAN: "&TOKEN);
REJECT←TRUE;
PLAN_STATEMENT←TRUE;
P_STATEMENT;
PLAN_STATEMENT←FALSE;
β;
procedure while_P;
α ! WHILE STATEMENT FOUND;
PRINT("("&LABL&"$WH");
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,11,"Conditional for WHILE must be boolean or sclar.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(12,"Missing DO. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! for_P,case_P,do_P;
procedure for_P;
α RPTR(ID_LIST,ARRAY_LIST) POINT;RPTR(DIMENS_EXPONENT)POINTD; ! FOR STATEMENT FOUND;
! ERROR_BUFFER←CURLINER;
RPTR(ID_PROP)IDP;
ifc false thenc GET_TOKEN;
IF TYPE_OF_TOKEN=undeclared_token
THEN
α MODIFY_CONTINUE(0,"Undeclared variable "&TOKEN&" declared a scalar");
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←scalar_VALUE;
ID_LIST:DIMEN[POINT]←NIL_DIMENS;
PRINT("($SVAR "&TOKEN&")");
β
ELSE
α POINT←TOKEN_PTR;
IF TYPE_OF_TOKEN≠id_token OR ID_TYPE≠scalar_value
THEN MODIFY_CONTINUE(1300, "Need scalar ID here.");
β;
endc IF (IDP←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IDP]≠SCALAR_VALUE
THEN modify_continue(1300,"Need scalar ID here.");
PRINT("("&LABL&"$FO "&ID_PROP:STOKEN[IDP]);
POINTD←ID_LIST:DIMEN[POINT←ID_PROP:TPTR[IDP]];
IF ID_PROP:TYPE[IDP]=ID_TOKEN THEN
α USE(POINT); DEFIN(POINT); β
ELSE α ARRAY_USE(POINT); ARRAY_DEFIN(POINT); β;
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"←") THEN
ERROR_REJECT(14,"Need left arrow here for FOR statement.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"STEP") THEN
ERROR_REJECT(16,"Need STEP here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"UNTIL") THEN
ERROR_REJECT(17,"Need UNTIL here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(18,"Need DO here.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
recursive procedure case_P;
α PRINT("("&LABL&"$CASE");
spacing←spacing+1;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(SCALAR_VALUE,NIL_DIMENS,
"index part of case statement")
THEN ERROR(19, "Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN, "OF") THEN ERROR_REJECT(20, "Need OF here in CASE statement");
get_token;
IF ¬EQU(TOKEN, "BEGIN") THEN ERROR_REJECT(21, "Need BEGIN here in CASE statement.");
GET_TOKEN; REJECT←TRUE;
IF EQU(TOKEN, "[") OR EQU(TOKEN,"ELSE") THEN
α BOOLEAN ELSE_SEEN; ELSE_SEEN←FALSE;
DO α GET_TOKEN;
IF EQU(TOKEN,"ELSE")
THEN IF ELSE_SEEN THEN ERROR(20, "ELSE seen twice in this CASE statement")
ELSE α ELSE_SEEN←TRUE; PRINT (" -1"); β
ELSE IF EQU(TOKEN,"[")
THEN α GET_TOKEN;
IF TYPE_OF_TOKEN≠numeric_token then
ERROR(21,"require an integer number here for numbered case statement");
PRINT(TOKEN);
GET_TOKEN;
IF ¬EQU(TOKEN,"]") THEN ERROR(22,"Need ] here for numbered case statement");
β
ELSE ERROR(24,"Need [ or ELSE here in CASE statement");
GET_TOKEN; REJECT←TRUE;
IF ¬EQU(TOKEN,"[") AND ¬EQU(TOKEN,"ELSE")
THEN α P_STATEMENT;
GET_TOKEN;
IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END")
THEN ERROR(23,"Need ; or END between statements in a CASE statement");
β;
β UNTIL EQU(TOKEN,"END");
β
ELSE DO α P_STATEMENT; GET_TOKEN;
IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END")
THEN ERROR(24,"need ; between statements in CASE statement");
β UNTIL EQU(TOKEN,"END");
spacing←spacing - 1;
print(")");
β;
procedure do_P;
α print("("&labl&" $UNTL");
SPACING←SPACING+1;
P_statement;
Get_token;
if not equ(token,"UNTIL") then error_reject(35, "need UNTIL here for DO statement, continue will insert");
printout;
p_exp;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,0,"NEED A BOOLEAN EXPRESSION IN DO...UNTIL STATEMENT");
SPACING←SPACING-1;
print(")");
printout;
β;
! retry_p,move_P,affix_P,unfix_P;
procedure retry_p;
PRINT ("($RETRY)");
recursive procedure move_P;
α RPTR(ID_PROP)IDX; STRING SAV_CURDEV;
SAV_CURDEV←CURRENT_DEVICE;
IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here.");
IF EQU(CURRENT_FRAME←ID_PROP:STOKEN[IDX],"BPARK") OR EQU(CURRENT_FRAME,"YPARK")
THEN MODIFY_FLUSH(0,19,"You can't move "&CURRENT_FRAME&" !!!!");
PRINT("("&LABL&"$MO "&CURRENT_FRAME& " ()");
SPACING←SPACING+1;
CURRENT_DEVICE←"ARM";
P_CLAUSES("ARM");
CURRENT_DEVICE←SAV_CURDEV;
CURRENT_FRAME←null;
SPACING←SPACING-1;
PRINT(")");
β;
procedure affix_p;
α RPTR(ID_PROP) IDX1,IDX2,IDXB,IDXA;
STRING TRANS; RPTR(ID_LIST,ARRAY_LIST) POINT;
BOOLEAN BY_FLAG, AT_FLAG, RIGID_FLAG;
STRING BY_S,AT_S,RIGID_S;
IF (IDX1←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IDX1]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here for affixment.")
ELSE POINT←ID_PROP:TPTR[IDX1];
DEFIN(POINT,ID_PROP:TYPE[IDX1]); AFFIX(POINT,ID_PROP:TYPE[IDX1]);
CURRENT_FRAME←ID_PROP:STOKEN[IDX1];
IF ¬CHECK_NEXT_TOKEN(21,NULL,"TO") THEN REJECT←TRUE;
IF (IDX2←GET_ID)=NULL_RECORD or ID_PROP:ID_CLASS[IDX2]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,12,"Need frame ID here for affixment.")
ELSE POINT←ID_PROP:TPTR[IDX2];
! IF ¬DEFINED(POINT) THEN UNDEFINED_VAR; ! COMMENTED OUT FOR ARG;
AFFIX(POINT,ID_PROP:TYPE[IDX2]);
GET_TOKEN;
BY_FLAG←AT_FLAG←RIGID_FLAG←FALSE;
AT_S←RIGID_S←NULL;
WHILE ¬(BY_FLAG AND AT_FLAG AND RIGID_FLAG)
DO α INTEGER J; STRING S; J←1;
FOR S← "BY","AT","RIGIDLY","NONRIGIDLY"
DO IF EQU(TOKEN,S) THEN DONE ELSE J←J+1;
CASE J OF
α
[1] α IF BY_FLAG THEN ERROR(100,"double BY variable")
ELSE by_flag←true;
IF (IDXB←GET_ID)=NULL_RECORD OR ID_PROP:ID_CLASS[IDXB]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,24,"Need trans ID here for BY in affix statement.");
IF block_level_of_defn=0
THEN MODIFY_FLUSH(0,25,"You are using predeclared variable in BY part of affixment");
! IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
BY_S←ID_PROP:STOKEN[IDXB];
GET_TOKEN;
β;
[2] α IF AT_FLAG THEN ERROR(19,"Double AT variable")
ELSE AT_FLAG←TRUE;
P_EXP2; AT_S←OUTEXPR; GET_TOKEN;
β;
[3] [4]
α IF RIGID_FLAG THEN ERROR(21,"Can only specify rigid or nonrigid affixment once")
else rigid_flag←true;
RIGID_S←TOKEN; GET_TOKEN;
β;
[5] α IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"END") AND ¬EQU(TOKEN,"COEND")
THEN ERROR(22,"Cant use ⊂"&token&"⊃ in this affixment statement");
IF ¬AT_FLAG THEN α AT_FLAG←TRUE; AT_S←"()"; β;
IF ¬BY_FLAG THEN α BY_FLAG←TRUE; by_S←"()";β;
IF ¬RIGID_FLAG THEN α RIGID_FLAG←TRUE; RIGID_S←"RIGIDLY"; β;
β
β;
β;
REJECT←TRUE;
PRINT("("&LABL&"$AFFIX "&ID_PROP:STOKEN[IDX1]&" "&ID_PROP:STOKEN[IDX2]
&" "&BY_S&" "); SPACING←SPACING + 1;
PRINT(AT_S&" "&RIGID_S&")"); SPACING←SPACING-1;
CURRENT_FRAME←NULL;
β;
procedure unfix_P;
α RPTR(ID_LIST,ARRAY_LIST) POINT; ! UNAFFIX STATEMENT FOUND;
RPTR(ID_PROP) IDX1,IDX2;
IDX1←GET_ID;
IF IDX1=NULL_RECORD OR ID_PROP:ID_CLASS[IDX1]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,19,"Need frame ID here in unfix statement.");
POINT←ID_PROP:TPTR[IDX1];
IF ¬DEFINED(POINT,ID_PROP:TYPE[IDX1]) THEN UNDEFINED_VAR;
IF ¬AFFIXED(POINT,ID_PROP:TYPE[IDX1]) THEN UNAFFIXED_VAR;
CURRENT_FRAME←ID_PROP:STOKEN[IDX1];
IF ¬CHECK_NEXT_TOKEN(20,NULL,"FROM") THEN REJECT←TRUE;
IDX2←GET_ID;
IF IDX2=NULL_RECORD OR ID_PROP:ID_CLASS[IDX2]≠TRANS_VALUE
THEN MODIFY_FLUSH(0,15,"Need frame ID here in unfix statement.");
IF ¬DEFINED(POINT,ID_PROP:TYPE[IDX2]) THEN UNDEFINED_VAR;
PRINT("("&LABL&"$UNFIX"&" "&ID_PROP:STOKEN[IDX1]&" "&
ID_PROP:STOKEN[IDX2]&")"); CURRENT_FRAME←null;
β;
! signal_p, wait_p;
procedure signal_wait_P(string ws);
α
RPTR(ID_PROP)IDX;
IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠EVENT_VALUE
THEN MODIFY_FLUSH(0,19,"Need event ID here in a SIGNAL or WAIT statement.");
PRINT("("&LABL&"$EV "&ID_PROP:STOKEN[IDX]&" "&WS&")");
DEFIN(ID_PROP:TPTR[IDX],ID_PROP:TYPE[IDX]);
β;
procedure signal_P;
signal_wait_P(" +"); ! SIGNAL STATEMENT FOUND;
procedure wait_P;
signal_wait_P(" -"); ! WAIT STATEMENT FOUND;
! when_P;
IFC FALSE THENC
procedure when_P;
α RPTR (ID_LIST) POINT; STRING VAR, ALSO_OP, CHG_LAB;
BOOLEAN TEMP; LABEL RE_TRY;
! WHEN STATEMENT FOUND;
GET_TOKEN;
RE_TRY:
IF ¬EQU(TOKEN,"CHANGING") THEN
ERROR_REJECT(30,"Need word CHANGING here for a WHEN CHANGING statement."&
" Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN=undeclared_token THEN MODIFY_CONTINUE(31,"Undefined ID");
VAR←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"ALSO")
THEN ALSO_OP←"ALSO_DO"
ELSE IF EQU(TOKEN,"DON'T")
THEN ALSO_OP←"ALSO_DON'T"
ELSE IF EQU(TOKEN,"ONLY")
THEN ALSO_OP←"ALSO_ONLY"
ELSE MODIFY_CONTINUE(32,"Illegal ALSO_OP");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(33,"Need DO here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN TEMP←TRUE
ELSE IF ID_TYPE=ch_label_VALUE
THEN TEMP←FALSE
! ?????; ELSE IF ID_TYPE>world_VALUE
THEN
α ERROR(34,"Can only handle CH_LABEL here. Continue while delete this label.");
TEMP←TRUE;
β
ELSE TEMP←TRUE;
IF TEMP
THEN
α CHG_LAB←T_GEN; PRINT("($CHGLAB "&CHG_LAB&")"); REJECT←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE
α CHG_LAB←TOKEN; GET_TOKEN;
IF EQU(TOKEN,":")
THEN α TEMP←TRUE; CHANGER_HEAD←CHG_LAB&" CHG "; β
ELSE α REJECT←TRUE; PRINT("($"&ALSO_OP&" "&VAR&" "&CHG_LAB&")"); β;
β;
IF TEMP
THEN
α PRINT("($"&ALSO_OP&" "&VAR); SPACING←SPACING+1; P_STATEMENT;
SPACING←SPACING-1; PRINT(")");
β;
β;
ENDC
! dump_P;
procedure dump_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING;
! DUMP STATEMENT FOUND;
IDSTRING←null; GET_TOKEN;
IF ID_TYPE=world_VALUE
THEN PRINT("("&LABL&"$DBD "&TOKEN&")")
ELSE
α
DO α
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>event_VALUE THEN ERROR(35,"Undefined ID.");
IDSTRING←IDSTRING&" "&TOKEN;GET_TOKEN;
IF ¬EQU(TOKEN,"IN") and TOKEN≠";"
THEN
α IF TOKEN≠","
THEN ERROR_REJECT(36, "Need comma or IN or ; here. Continue will insert it.");
GET_TOKEN;
β;
β
UNTIL EQU(TOKEN,"IN") OR EQU(TOKEN,";");
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE
THEN ERROR(37,"Need a world ID here.")
ELSE IDSTRING←IDSTRING & " " & TOKEN;
β else reject←true;
PRINT ("("&LABL&"$PVL "&IDSTRING&")");
β;
β;
! assert_P;
IFC false thenc
procedure assert_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING,COM;INTEGER VAR_TYPE;
! ASSERT OR DENY STATEMENT FOUND;
COM←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"FORM")
THEN
α IDSTRING←null; GET_TOKEN;
IF ¬EQU(TOKEN,"(")
THEN ERROR_REJECT(37,"Need left paren here. Continue will insert it.");
WHILE ¬EQU(TOKEN,")")
DO α
GET_TOKEN; IDSTRING←IDSTRING&TOKEN&" "; GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",")
THEN ERROR_REJECT(38,"Need either comma or right paren here."&
" Continue will insert a comma.");
β;
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT("("&LABL&COM&" ($SF "&IDSTRING&") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("("&LABL&COM&" ($SF "&IDSTRING&"))"); β;
β
ELSE
α STRING VAR;
! ?????; IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>trans_VALUE
THEN
α ERROR(40,"Need variable ID here.");
POINT←SYMBOL_TABLE[HASH("GARB_ID",id_hasher)];
β
ELSE POINT←TOKEN_PTR;
VAR_TYPE←ID_TYPE;GET_TOKEN;
IF ¬EQU(TOKEN,"=")
THEN ERROR(41,"Sorry, can only handle equality right now.");
PRINT("("&LABL&COM&" ($AF "&VAR&" = "); SPACING←SPACING+1;
P_EXP; SPACING←SPACING-1;
IF VAR_TYPE≠EXP_TYPE THEN ERROR(42,"Types don't match on equality test.");
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT(") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("))"); β;
β;
β;
endc
! on_P, reference_P,deproach_P;
procedure on_P;
α RPTR (CONDITION)PTR;
! CONDITION MONITER FOUND;
BOOLEAN ICMT;
ICMT←INSIDE_CONDITION_MONITOR;
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN PRINT("( "&LABL&"$ON +")
ELSE BEGIN PRINT("( "&LABL&"$ON -");
CHECK_NEXT_TOKEN(27,null,"ON");
END;
PTR←GET_CONDITION("ON");
IF PTR=NULL_RECORD THEN MODIFY_FLUSH(0,2000,"INVALID condition in condition monitor statement");
IF CONDITION:TYPE[PTR]≠RELATIONAL_TYPE THEN
ERROR(2000,"Need relational condition for condition monitor");
SPACING←SPACING+1;
IF CONDITION:COND[PTR]=EXPRESSION_COND OR CONDITION:COND[PTR]=EVENT_COND
THEN PRINT(CONDITION:SEXP[PTR])
ELSE BEGIN
PRINT("(");
PRINT(CONDITION:SEXP[PTR]);
PRINT(")");
END;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO in condition monitor statement. Continue will insert it.");
P_STATEMENT;
INSIDE_CONDITION_MONITOR←ICMT;
SPACING←SPACING-1;
PRINT(")");
β;
IFC FALSE THENC
procedure reference_P;
α RPTR (ID_LIST) POINT; ! NEW WORLD DEF;
GET_TOKEN;
IF ¬EQU(TOKEN,"POINT") THEN
ERROR_REJECT(46,"Need POINT here for a REFERENCE POINT statement.");
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(47,"Need a world variable here.");
PRINT("("&LABL&"$NW "&TOKEN&")");
β;
ENDC
IFC FALSE THENC
procedure deproach_P;
α
RPTR(ID_PROP) IDX;
string ss; ss←"("&labl&" $DEPROACH ";
get_token;
IF ¬EQU(TOKEN,"(") THEN ERROR_reject (47, "need left paren after deproach");
IF (IDX←GET_ID)=NULL_RECORD OR (ID_PROP:ID_CLASS[IDX] ≠ TRANS_VALUE)
THEN
error(47, "only frames can have deproaches");
SS←SS&id_prop:stoken[idx];
get_token;
IF TOKEN≠")" THEN ERROR(48, "need right paren here in deproach statement");
get_token;
IF TOKEN≠"←" THEN ERROR(49, "need ← here in deproach statement");
p_exp2;
SS←SS&" "&OUTEXPR&")"; PRINT(SS);
β;
ENDC
procedure deproach_p;
F_STATE(47,"DEPROACH statement is now defunct");
! open_P,center_P,stop_P,enable_P,disable_P;
recursive procedure handcode(STRING HAND);
α STRING SAV_CURDEV;
check_next_token(49,NULL,"TO");
PRINT("("&LABL&"$MO "&HAND);
SPACING←SPACING+1;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DISTANCE_DIMENS,
"OPEN/CLOSE statement")
THEN ERROR(121,"Need scalar quantity here in an OPEN or CLOSE statement");
SAV_CURDEV←CURRENT_DEVICE;
CURRENT_DEVICE←"HAND";
P_CLAUSES("HAND");
CURRENT_DEVICE←SAV_CURDEV;
SPACING←SPACING-1;
PRINT(")");
β;
recursive procedure visecode(STRING SIGN);
α STRING SAV_CURDEV;
PRINT("("&LABL&"$OPERATE VISE ");
SPACING←SPACING+1;
GET_TOKEN;
IF EQU(TOKEN,"TO") THEN
α
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DISTANCE_DIMENS,
"OPEN/CLOSE VISE statment")
THEN ERROR(122,"Need scalar quantity here in an OPEN or CLOSE statement");
β
ELSE BEGIN PRINT(SIGN); REJECT←TRUE; END;
SAV_CURDEV←CURRENT_DEVICE;
CURRENT_DEVICE←"VISE";
P_CLAUSES("VISE");
CURRENT_DEVICE←SAV_CURDEV;
SPACING←SPACING -1;
PRINT(")");
β;
recursive procedure open_P;
α STRING HAND; ! OPEN/CLOSE FOUND;
STRING SIGN;
RPTR (ID_LIST) POINT;
IF EQU(TOKEN,"OPEN") THEN SIGN←" + " ELSE SIGN←"-";
check_next_token(48,"Unknown hand in OPEN/CLOSE statement",
"BHAND","YHAND","VISE"); HAND←TOKEN;
IF EQU(HAND,"VISE") THEN visecode(SIGN) ELSE handcode(HAND);
β;
procedure center_P;
IF check_next_token(50,"Unknown arm in CENTER statement",
"BARM","YARM") then
α PRINT("("&LABL&"$CENTER "&TOKEN);
P_CLAUSES("BARM");
PRINT(")");
β;
procedure stop_P;
α ! STOP FOUND;
RPTR(ID_LIST) R1;
GET_TOKEN;
IF (R1←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α IF (ID_LIST:TYPE[R1]=TRANS_VALUE) OR
EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
THEN PRINT("("&LABL&"$STOP "&TOKEN&")")
ELSE ERROR(49, "Trying to stop a non-frame");
β
ELSE α IF TYPE_OF_TOKEN = undeclared_token
THEN PRINT("("&LABL&" $STOP "&TOKEN&")")
ELSE α REJECT←TRUE; PRINT("("&LABL&"$STOP )");β;
β;
β;
procedure denable_P(STRING en);
α ! ENABLE/DISABLE found;
STRING S1;
s1← "(" & LABL & " $CMABLE " & en;
GET_TOKEN;
IF ID_TYPE = LABEL_VALUE
THEN α S1← S1&TOKEN&" )"; USE(TOKEN_PTR); β
ELSE α REJECT←TRUE; IF INSIDE_CONDITION_MONITOR
THEN S1 ← S1 & " )"
ELSE ERROR(123, "Only label can be used in ENABLE or DISABLE statement.");
β;
PRINT(S1);
β;
procedure enable_P;
denable_P(" + ");
procedure disable_P;
denable_P(" - ");
! require_P;
procedure require_P;
α ! REQUIRE STATEMENT FOUND;
LABEL RE_TRY;
GET_TOKEN;
RE_TRY:
IF ¬(require_beg ≤ TYPE_OF_RES_WORD ≤ require_end)
THEN α IF MODIFY_FLUSH(0,51,"Illegal token after REQUIRE") THEN GOTO RE_TRY; β
ELSE
CASE TYPE_OF_RES_WORD - require_beg OF
α
[source_file_X] α
integer res_word_sav; string new_file,sav_token;
GET_TOKEN;
new_file←token;
GET_TOKEN;
sav_token←token; res_word_sav←type_of_res_word;
TOP_SOURCE←PUSH_SOURCE_LIST(TOP_SOURCE);
SOURCE_LIST:NUM[TOP_SOURCE]←0;
WHILE ¬ got_input(PRESENT_file←open_new_file(new_file))
DO α ERROR(55,"FILE NOT AVAILABLE");
new_file←infile; β;
CHANIN←file:chn[PRESENT_FILE];
if equ(file:device[PRESENT_file],"TTY")
then
α
CHECK_WANT_COPY;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
β;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
open_NEW_AL_FILE(PRESENT_FILE, "NEW");
endc
pagenum←linenum←0;
GET_TOKEN;
IF EQU(CURLINE[1 TO 17],"COMMENT ⊗ VALID")
THEN α GARB←READ(SEMICOLON_A_BREAK); get_token; β;
PARSED_STRING←null; curliner←curline;
token←sav_token;
type_of_res_word←res_word_sav;
reject←true;
switch_file←true;
β;
[message_x] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_FLUSH(0,52,"Need string after REQUIRE MESSAGE");
OUTSTR(TOKEN);
β;
[error_modes_x] α
INTEGER I,L; STRING S; BOOLEAN T;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_FLUSH(0,52,"Need string after REQUIRE ERROR_MODES");
L←length(token);
FOR I←1 STEP 1 UNTIL L DO
α S←TOKEN[I FOR 1];
IF EQU(S,"-") THEN α I←I+1;
S←TOKEN[I FOR 1];
T←FALSE;
β
ELSE T←TRUE;
CASE S OF
α
["L"] α COMPILE_LOGGING←T;
IF ¬T THEN LOGGING←T; β;
["A"] AUTO_PROCEED←T;
["F"] STRICT_DIMEN_CHECK←T;
["M"] PROMPT_FOR_MODIFIABLE_ERROR_ONLY←T;
["N"] WANT_DUP_FILE←FALSE;
ELSE ERROR(0,"Error_mode " & s & " undefined. Only modes LAFMN are applicable")
β;
β;
β;
[compiler_switches_x] α
INTEGER I,L,I1; STRING S; BOOLEAN NON_EXIST_SWITCH,BAIL_WANTED;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
L←LENGTH(TOKEN);
FOR I←1 STEP 1 UNTIL L DO
α
S←TOKEN[I FOR 1];
NON_EXIST_SWITCH←TRUE;
FOR I1←0 STEP 1 UNTIL SWITCH_MAX DO
IF EQU(S,SWITCH_NAME[I1]) THEN
α SWITCH_SETTING[I1]←TRUE;
IF I1=B_X THEN BAIL_WANTED←TRUE;
NON_EXIST_SWITCH←FALSE;
β;
IF NON_EXIST_SWITCH THEN
ERROR(0,"Switch " & S & " unknown");
β;
IF BAIL_WANTED
THEN α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
β;
[bail_X] α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
β;
β;
! operate_p;
procedure operate_P;
α STRING SAV_DEVICE;! OPEN/CLOSE FOUND;
RPTR (ID_LIST) POINT;
check_next_token(48,"Unknown device in OPERATE statement",
"DRIVER");
PRINT("("&LABL&"$OPERATE DRIVER () ");
SPACING←SPACING+1;
SAV_DEVICE←CURRENT_DEVICE;
CURRENT_DEVICE←"DRIVER";
P_CLAUSES("DRIVER");
CURRENT_DEVICE←SAV_DEVICE;
SPACING←SPACING-1;
PRINT(")");
β;
! dimension_P;
procedure dimension_P;
α "dimen_p"
! DIMENSION STATEMENT FOUND;
STRING DIMEN_NAME;
RPTR(DIMENS_EXPONENT) D1;
forward recursive rptr(dimens_exponent) procedure factor;
recursive rptr(dimens_exponent) procedure term;
α rptr(dimens_exponent) r1,R2;
R1←FACTOR;
IF R1=NULL_RECORD THEN ERROR(0000,"invalid expression.");
WHILE TOKEN="*" OR TOKEN="/" DO
α
STRING S; S←TOKEN;
GET_TOKEN;
R2←FACTOR;
IF S="*" THEN R1←MULTIPLY_DIMENSIONS(R1,R2)
ELSE R1←DIVIDE_DIMENSIONS(R1,R2);
β;
RETURN(R1);
β;
recursive rptr(dimens_exponent)procedure factor;
α rptr(dimens_exponent)r1,r2;
IF TOKEN="(" THEN
α R1←TERM; IF TOKEN≠")" THEN ERROR(0000,"unbalanced paren")
else get_token;
β
ELSE IF TOKEN = "INV" THEN
α GET_TOKEN; IF TOKEN≠"(" THEN ERROR(0000,"need open paren after INV, proceed will insert")
ELSE R2←TERM;
R1←DIVIDE_DIMENSIONS(NIL_DIMENS,R2);
β
ELSE α
r1←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE);
IF r1=NULL_RECORD THEN ERROR(0000, TOKEN & "not declared.")
ELSE GET_TOKEN;
β;
RETURN(R1);
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token AND BLOCK_LEVEL_OF_DEFN=BLOCK_LEVEL
THEN MODIFY_FLUSH(0,61,"Can only use unreserved ID's for dimensions.");
DIMEN_NAME←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(62,"Need = in DIMENSION statement.");
GET_TOKEN;
D1←TERM;
IF TOKEN≠";" THEN ERROR(0000,"NEED SEMICOLON HERE");
IF D1=NULL OR D1=NIL_DIMENS THEN
insert_entry(DIMEN_NAME,DIMENSION_TYPE_TABLE)
ELSE INSERT_ENTRY(DIMEN_NAME,DIMENSION_TYPE_TABLE,D1);
REJECT←TRUE;
β "dimen_p";
! string_P;
ifc false thenc
procedure string_P;
α
BOOLEAN NEW;RPTR(ID_LIST)R1; LABEL RE_TRY;
INSIDE_STRING_DECLARATION←TRUE;
IF EQU(TOKEN,"NEW_STRING") THEN NEW←TRUE ELSE NEW←FALSE;
GET_TOKEN;
RE_TRY:
R1←TOKEN_PTR;
IF NEW
THEN α IF R1=NULL_RECORD OR ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]≠BLOCK_LEVEL
THEN r1←insert_entry(token,id_type_table)
ELSE MODIFY_CONTINUE(12,TOKEN &" already defined");
β
ELSE IF R1=NULL_RECORD
THEN α ERROR( 13, TOKEN &" not defined, will define"); R1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE) β;
get_token;
if token≠"=" THEN ERROR_REJECT(15,"Need ""="" here, continue will insert it");
INSIDE_STRING_DECLARATION←FALSE;
id_list:body[r1]←string_expr;
id_list:type[r1]←string_value;
β;
endc
! abort_P, note_P,comment_P,speed_factor_P,wrist_P,setbase_P;
procedure abort_P;
α ! PRINT/ABORT/PAUSE STATEMENT FOUND;
IF EQU(TOKEN,"PAUSE") THEN
α
p_exp2;
IF EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,1102,"Need a scalar expression here for a PAUSE statement.");
PRINT("( $PAUSE "&OUTEXPR&")");
β
ELSE α
PRINT("( $"&TOKEN&" ");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1104,"Need left paren here, continue will insert it.");
TOKEN←",";
WHILE EQU(TOKEN,",") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN=string_token THEN PRINT(dquote&TOKEN&dquote)
ELSE α
REJECT←TRUE;
P_EXP;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(1103,"Illegal separator. Continue"&
" will try to insert reasonable separator.");
β;
IF ¬EQU(TOKEN,")") THEN
ERROR(1104,"Need right paren here, continue will insert it.");
SPACING←SPACING-1;
PRINT(")");
β;
β;
procedure note_P;
α
BOOLEAN LPAR; STRING T,T2;
LPAR←FALSE;
T←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN α LPAR←TRUE; GET_TOKEN β;
IF TYPE_OF_TOKEN≠string_token then F_STATE(0,1102,
"Need string expression here for "& token & " statement.")
ELSE
α T2←TOKEN;
IF LPAR THEN α GET_TOKEN; IF ¬EQU(TOKEN,")") THEN ERROR(1234,
"Parenthesis mismatch.") β;
PRINT("( $"& T & space & dquote & T2 & dquote & " )");
β;
β;
procedure comment_P;
GARB←READ(semicolon_A_break);
procedure speed_factor_P;
α
GET_TOKEN;
IF ¬TOKEN_EQU("←") THEN ERROR_REJECT(37, "Need ← here");
p_exp2;
IF EXP_TYPE≠SCALAR_VALUE THEN ERROR(36, "Need to have scalar expression for SPEED_FACTOR");
PRINT("($SPEED_FACTOR "&OUTEXPR& " )");
β;
procedure SETBASE_P;
PRINT("("&LABL&"$SETBASE)");
procedure WRIST_P;
α
RPTR(ID_PROP)IDX;
GET_TOKEN;
IF ¬TOKEN_EQU("(") THEN ERROR_REJECT(37,"Need ( here");
IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠VECTOR_VALUE
THEN error(45,"Need two vectors as arguments of WRIST")
ELSE BEGIN
PRINT("("&LABL&" $WRIST "&ID_PROP:STOKEN[IDX]& " ");
GET_TOKEN;
IF TOKEN≠"," THEN ERROR_REJECT(37,"Need , here");
IDX←GET_ID;
IF IDX=NULL_RECORD OR ID_PROP:ID_CLASS[IDX]≠VECTOR_VALUE
THEN ERROR(1010,"Need vector for WRIST");
GET_TOKEN;
IF ¬TOKEN_EQU(")")THEN ERROR_REJECT(37,"Need ) here")
ELSE PRINT(ID_PROP:STOKEN[IDX]&")");
END;
β;
! define_P,declare_P,global_P,procedure_P,return_P;
procedure define_P;
if ¬macro_handler then goto FLUSH;
rclass tstack(rptr(id_list,array_list)ptr; integer isid; rptr(tstack)next);
rptr(tstack) tstacktop,tstacktemp;
procedure pushtstack(rptr(id_list,array_list)rr; integer isid);
α tstacktemp←new_record(tstack);
tstack:ptr[tstacktemp]←rr;tstack:isid[tstacktemp]←isid;
tstack:next[tstacktemp]←tstacktop;
tstacktop←tstacktemp;
β;
boolean procedure findintstack(string tt);
α rptr(tstack)temp;
temp←tstacktop;
while temp≠null_record do
α if tstack:isid[temp] then
α if equ(tt,id_list:name[tstack:ptr[temp]]) then return(true); β
else if equ(tt,array_list:name[tstack:ptr[temp]]) then return(true);
temp←tstack:next[temp];
β;
return(false);
β;
recursive procedure declare2_P(reference string dec_string; reference integer how_many;
rptr(dimens_exponent)dim_ptr; integer type1,blklvl);
α integer type2; boolean save_inside_declar_p;
save_inside_declar_p←inside_declare_p;
inside_declare_P←true;
if type1=frame_value then type2←trans_value else type2←type1;
if equ(token,"ARRAY") then
α "array list"
string ss; rptr(array_list)aptr; integer i0,i1; i1←i0←0;
aptr←null_record; ss←"$ARAY "&dec_name[type1]&" ";
do α "look for valid id"
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3001,token&" is a reserved word and may not be used an an identifier name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=blklvl or findintstack(token)
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else
α "found suitable id" integer nfields; nfields←0;
ss←ss&token&" (";
array_list:name[aptr←new_record(array_list)]←token;
array_list:dimen[aptr]←dim_ptr;
array_list:type[aptr]←type2;
array_list:block_level_of_defn[aptr]←blklvl;
pushtstack(aptr,false);
get_token;
i0←0;
if token≠"[" then MODIFY_FLUSH(0,3001,"need [ for delimiting fields of array declaration");
do α
p_exp2;
check_exp_type_dimens(scalar_value,nil_dimens,
"limits of array identifier which should be an undimensioned scalar expression");
ss←ss&outexpr;
get_token;
if token≠":" then MODIFY_FLUSH(0,3002,"need : to separate the ranges of the array limits");
p_exp2;
check_exp_type_dimens(scalar_value,nil_dimens,
"limits of array identifier which should be an undimensioned scalar expression");
get_token; nfields←nfields+1;
ss←ss&" "&outexpr; i0←i0+1;
if token≠"]" and token≠"," then MODIFY_FLUSH(0,3003, "need , or ] here in array declaration");
β until token="]";
ss←ss&" )"; i1←i1+1;
array_list:#dimens[aptr]←i0;
β "found suitable id";
get_token;
if token≠";" and token≠"," and not equ(token,"END") and token≠")"
then MODIFY_FLUSH(0,3003,"need ; or , here");
β "look for valid id" until token≠",";
reject←true;
dec_string←ss; how_many←i1;
β "array list"
else α "identifier list"
string ss; rptr(id_list)iptr; integer i1; i1←0;
ss←dec_name[type1]&" ";
reject←true;
do α "look for valid id"
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3001,token&" is a reserved word and may not be used an an identifier name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=blklvl or findintstack(token)
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else ss←ss&token&" ";
id_list:name[iptr←new_record(id_list)]←token;
id_list:dimen[iptr]←dim_ptr;
id_list:type[iptr]←type2;
id_list:block_level_of_defn[iptr]←blklvl;
pushtstack(iptr,true);
get_token;
if token≠";" and token≠"," and not equ(token,"END") and not equ(token,")")
then MODIFY_FLUSH(0,3003,"need ; or , here");
i1←i1+1;
β "look for valid id" until token≠",";
reject←true;
dec_string←ss; how_many←i1;
β "identifier list";
inside_declare_p←save_inside_declar_p;
β;
PROCEDURE PROCEDURE2_P(STRING DEC_STRING; RPTR(DIMENS_EXPONENT) DIM; INTEGER TYPE1);
α "procedure2_P"
rptr(dimens_exponent) dim2;string procname;
rptr(procedure_list)pptr;
integer type2;string ss,sss;integer totnarg;
INTEGER SAVE_DEC_NUM,SAVE_MACRO_DEC_NUM,SAVE_DIMEN_DEC_NUM,
SAVE_ARRAY_DEC_NUM,SAVE_PROCEDURE_DEC_NUM;
record_pointer(any_class) rr;
INTEGER I;
SAVE_DEC_NUM←DEC_NUM;DEC_NUM←0;
SAVE_ARRAY_DEC_NUM←ARRAY_DEC_NUM;ARRAY_DEC_NUM←0;
SAVE_PROCEDURE_DEC_NUM←PROCEDURE_DEC_NUM; PROCEDURE_DEC_NUM←0;
SAVE_MACRO_DEC_NUM←MACRO_DEC_NUM;MACRO_DEC_NUM←0;
SAVE_DIMEN_DEC_NUM←DIMEN_DEC_NUM;DIMEN_DEC_NUM←0;
if type1=frame_value then type2←trans_value else type2←type1;
if type1=0 then ss← "$PROC " else ss← "$PROC "&dec_name[type1];
get_token;
if type_of_token=reserved_token
then MODIFY_FLUSH(0,3004,TOKEN&" is reserved and may not be used as procedure name")
else if block_level_of_defn=0
then MODIFY_FLUSH(0,3002,token&" is an AL declared identifier")
else if block_level_of_defn=block_level
then MODIFY_FLUSH(0,3003,TOKEN & " has already been declared")
else ss←ss&" "&token&" "; print(ss); ss←null;
procname←token;
get_token;
totnarg←0; tstacktop←null_record;
if token="("
then
α "procedure with arguments"
do
α "arguments in procedure"
integer narg, nn; string ssstoken;
get_token; ss←ss&"(";
if equ(token,"VALUE") or equ(token,"REFERENCE") then
α SS ← ss&" $"&token[1 to 3]&" "; get_token; β;
if type_of_token=metric_token then
α dim2←token_ptr; get_token; β;
if type_of_res_word=declare_res then
α nn←special_info;ssstoken←token; get_token; β else
MODIFY_FLUSH(0,3006,"need a type declaration here");
if nn≠vector_value and nn≠scalar_value and
nn≠trans_value and dim2≠null_record
then MODIFY_FLUSH(0,3000,ssstoken & " cannot take arbitrary dimensions");
if dim2=null_record then
case nn of
α
[scalar_value]
[plane_value]
[vector_value] DIM2←NIL_DIMENS;
[rot_value] DIM2←ANGLE_DIMENS;
[trans_value] DIM2←DISTANCE_DIMENS;
[frame_value] DIM2←DISTANCE_DIMENS;
ELSE DIM2←NULL_RECORD
β;
declare2_P(sss,narg,dim2,nn,block_level+1);
totnarg←totnarg + narg;
ss←ss&sss&")";
get_token;
if token≠";" and token≠")" then MODIFY_FLUSH(0,3007,
"need ; or ) to end argument list for procedure arguments");
β "arguments in procedure" until token=")";
β "procedure with arguments"
else α reject←true; β;
dec_string←ss;
get_token; if token≠";" then MODIFY_FLUSH(0,3008,"need ; at end of procedure declaration");
pptr←new_record(procedure_list);
if totnarg>0 then
α integer array isid,argmode[1:totnarg]; integer i;
rptr (id_list,array_list) array args[1:totnarg];
procedure_list:#args[pptr]←totnarg;
for i←totnarg step -1 until 1 do
α rptr(id_list,array_list)aiptr;
aiptr←tstack:ptr[tstacktop];
args[i]←aiptr;
if (isid[i]←tstack:isid[tstacktop]) then
insert_entry(id_list:name[aiptr],id_type_table,aiptr)
else insert_entry(array_list:name[aiptr],array_type_table,aiptr);
tstacktop←tstack:next[tstacktop];
β;
if tstacktop≠null_record then MODIFY_FLUSH(0,3009,"PARSER ERROR 3009 NON EMPTY STACK");
MEMORY[LOCATION(ARGS)]↔MEMORY[LOCATION(PROCEDURE_LIST:ARGS[PPTR])];
MEMORY[LOCATION(ISID)]↔MEMORY[LOCATION(PROCEDURE_LIST:ISID[PPTR])];
β;
insert_entry(procname,procedure_type_table,pptr);
procedure_list:type[pptr]←type2;
procedure_list:dimen[pptr]←dim;
print("("&ss&")"); printout;
p_statement;
printout;
print(")"); printout;
FOR I←1 STEP 1 UNTIL MACRO_DEC_NUM DO
α
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_MACRO],macro_hasher)]
←MACRO_LIST:NEXT[TOP_MACRO];
TOP_MACRO←MACRO_LIST:LAST[RR←TOP_MACRO];
β;
FOR I←1 STEP 1 UNTIL DIMEN_DEC_NUM DO
α
DIMENS_TABLE[HASH(DIMENS_EXPONENT:NAME[TOP_DIMENS],metric_hasher)]
←DIMENS_EXPONENT:NEXT[TOP_DIMENS];
TOP_DIMENS←DIMENS_EXPONENT:LAST[rr←TOP_DIMENS];
β;
FOR I←1 STEP 1 UNTIL ARRAY_DEC_NUM DO
α
ARRAY_SYMBOL_TABLE[HASH(ARRAY_LIST:NAME[TOP_ARRAY],array_hasher)]
←array_list:NEXT[TOP_array];
TOP_array←array_list:LAST[rr←TOP_array];
β;
FOR I←1 STEP 1 UNTIL procedure_DEC_NUM DO
α
procedure_SYMBOL_TABLE[HASH(procedure_LIST:NAME[TOP_procedure],procedure_hasher)]
←procedure_list:NEXT[TOP_procedure];
TOP_procedure←procedure_list:LAST[rr←TOP_procedure];
β;
DEC_NUM←SAVE_DEC_NUM;
MACRO_DEC_NUM←SAVE_MACRO_DEC_NUM;
ARRAY_DEC_NUM←SAVE_ARRAY_DEC_NUM;
PROCEDURE_DEC_NUM←SAVE_PROCEDURE_DEC_NUM;
DIMEN_DEC_NUM←SAVE_DIMEN_DEC_NUM;
insert_entry(procname,procedure_type_table,pptr);
β "procedure2_P";
procedure procedure_p;
α string ss; PRINT("("&LABL&" "); procedure2_p(ss,nil_dimens,0); β;
PROCEDURE DECLARE_P;
α integer type1; rptr(dimens_exponent)dim; string ss,sss; integer howmany;
string stemp;
dim←dim_ptr;
if (type1←special_info)≠vector_value and special_info≠scalar_value and
special_info≠trans_value and dim≠null_record
then MODIFY_FLUSH(0,3000,token & " cannot take arbitrary dimensions");
if dim=null_record then
case special_info of
α
[scalar_value]
[plane_value]
[vector_value] DIM←NIL_DIMENS;
[rot_value] DIM←ANGLE_DIMENS;
[trans_value] DIM←DISTANCE_DIMENS;
[frame_value] DIM←DISTANCE_DIMENS;
ELSE DIM←NULL_RECORD
β;
get_token;
stemp←"("&labl&" "; SS←Null;
if equ(token, "PROCEDURE")
then α print(stemp); procedure2_P(SS,dim,type1); β
else α integer i; rptr(id_list,array_list)iptr;
tstacktop←null_record;
DECLARE2_P(SS,HOWMANY,DIM,TYPE1,BLOCK_LEVEL);
print(stemp&ss&")");
FOR i←1 step 1 until howmany do
α iptr←tstack:ptr[tstacktop];
if tstack:isid[tstacktop] then insert_entry(id_list:name[iptr],id_type_table,iptr)
else insert_entry(array_list:name[iptr],array_type_table,iptr);
tstacktop←tstack:next[tstacktop];
β;
β;
β;
PROCEDURE RETURN_P;
α string s; s←labl;
get_token; reject←true;
if equ(token,";") or equ(token,"END") OR EQU(TOKEN,"ELSE")
THEN PRINT("("&S&" $RET )")
ELSE α p_exp2; print("("&s&" $RET "&outexpr&")"); β;
β;
! P_statement execution starts here;
INSIDE_STATEMENT←-100;
SAVSPACING←SPACING;
GET_TOKEN;
WHILE EQU(TOKEN,"COMMENT") DO
α GARB←READ(semicolon_A_break); GET_TOKEN; β;
GLOBAL_RE_TRY: SPACING←SAVSPACING;
LABL←CHANGER_HEAD; ! USUALLY NULL EXCEPT WHEN INSIDE A CHANGER.;
CHANGER_HEAD←null; LABEL_TYPE←0;
DIM_PTR←NULL_RECORD;
CURRENT_DEVICE←NULL;
TRY_AGAIN:
CASE TYPE_OF_TOKEN OF
α
[numeric_token] MODIFY_FLUSH(0,1,"Statement can't begin with a scalar");
[string_token] MODIFY_FLUSH(0,2,"Statement can't begin with a string");
[macro_token] MODIFY_FLUSH(0,3,"PARSER ERROR, MACRO TOKEN FOUND");
[metric_token] IF DIM_PTR=NULL_RECORD
THEN α DIM_PTR←TOKEN_PTR; GET_TOKEN; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH(0,56,"AMBIGUOUS DIMENSIONS");
[procedure_token]
α reject←true; p_exp2; print("("&labl&" " &outexpr[2 to ∞ - 1]&")"); β;
[id_token] IF DIM_PTR = NULL_RECORD
THEN
α
IF BLOCK_LEVEL_OF_DEFN≠0 OR TOKEN_EQU("BARM","YARM","BHAND","YHAND",
"FIXED_JAW","MOVING_JAW","DRIVER_TIP","DRIVER_GRASP")
THEN
CASE (ID_TYPE + 3)OF
α
[LABEL_VALUE +3]
α LABEL_TYPE←ID_TYPE;
IF DEFINED(TOKEN_PTR) THEN ERROR(22,"Label multiply used.");
DEFIN(TOKEN_PTR);
IF EQU(LABL,null) THEN LABL←TOKEN&" " ELSE ERROR(22,"Double label.");
check_next_token(23, NULL ,":");
GET_TOKEN; GO TO TRY_AGAIN;
β;
[form_value +3]
[boole_VALUE +3]
[SCALAR_VALUE +3]
[VECTOR_VALUE +3]
[ROT_VALUE +3]
[FRAME_VALUE +3]
[PLANE_VALUE +3]
[TRANS_VALUE +3]
α STRING ID, AS; RPTR(DIMENS_EXPONENT) ID_DIMEN;INTEGER ID_T,BL;
RPTR(ID_LIST) R1; R1←TOKEN_PTR;
BL←BLOCK_LEVEL_OF_DEFN;
ID←TOKEN; ID_T←ID_TYPE; ID_DIMEN←ID_LIST:DIMEN[TOKEN_PTR]; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS; GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS ";REJECT←TRUE;
IF (BL=0) AND ¬EQU(ID,"DRIVER_GRASP") AND
¬EQU(ID,"DRIVER_TIP") AND ¬EQU(ID,"FIXED_JAW")
THEN F_STATE(0,7,"TRYING TO ASSIGN VALUE TO ARM OR DEVICE"); β
ELSE AS←"PAS ";
SS←"("&LABL&" $"&AS&id; P_EXP2;
IF EXP_TYPE=0 THEN OUTEXPR← "( )" ELSE
IF ¬CHECK_EXP_TYPE_DIMENS(ID_T,ID_DIMEN,"assignment statement")
THEN ERROR(121,"Type mismatch on assignment.");
DEFIN(R1); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN α REJECT←TRUE; TEMP←FALSE;PRINT("("&LABL&" $"&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")"); β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("($CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&" $"&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH(0,0,"Can't start this way")
β;
β;
[string_VALUE +3]
F_STATE(0,2,"Statement can't begin with a string");
ELSE F_STATE(0,4,"Statement can't begin this way")
β
ELSE MODIFY_FLUSH(0,7,"Assignment statement can't begin with predefined constant");
β
ELSE ERROR(25, "CANNOT HAVE DIMENSION IN FRONT OF VARIABLE");
[array_token] IF DIM_PTR = NULL_RECORD
THEN
α INTEGER ARRAY_T; RPTR(DIMENS_EXPONENT)ARRAY_D;
STRING AS;
ARRAY_T←ARRAY_TYPE; ARRAY_D←ARRAY_LIST:DIMEN[TOKEN_PTR];
REJECT←TRUE;
P_EXP2;
GET_TOKEN;
IF TOKEN = "←" THEN
α STRING SS; GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS ";REJECT←TRUE;
β
ELSE AS←"PAS ";
SS←"("&LABL&" $"&AS&outexpr; P_EXP2;
IF EXP_TYPE=0 THEN OUTEXPR← "( )" ELSE
IF ¬CHECK_EXP_TYPE_DIMENS(array_T,array_D,"assignment statement")
THEN ERROR(121,"Type mismatch on assignment.");
! DEFIN(R1); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β
ELSE ERROR(122, "need ← here ");
β
ELSE ERROR(25, "CANNOT HAVE DIMENSION IN FRONT OF VARIABLE");
[undeclared_token]
α STRING ID, AS; INTEGER ID_T;RPTR(DIMENS_EXPONENT) ID_DIMEN;
RPTR(ID_LIST) POINT; ID←TOKEN; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS;GET_TOKEN;
IF ¬EQU(TOKEN,"←")THEN α AS←"AS "; REJECT←TRUE; β ELSE α AS←"PAS "; β;
SS←"("&LABL&"$"&AS&id; P_EXP2;
IF MODIFY_CONTINUE(0,"Undefined variable "&id&crlf&
"Continue will declare it . Modify will allow correction.")
THEN GOTO TRY_AGAIN
ELSE
α POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←EXP_TYPE; ID_LIST:DIMEN[POINT]←EXP_DIMENS;
IF EXP_TYPE=Trans_VALUE THEN ID_T←frame_VALUE ELSE ID_T←EXP_TYPE;
PRINT("("&DEC_NAME[ID_T]&" "&ID&")");
DEFIN(POINT); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
RPTR(ID_LIST) POINT; POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←trans_VALUE; DEFIN(POINT);
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN
α REJECT←TRUE; TEMP←FALSE;
PRINT("("&LABL&"$GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")");
β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("($CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&"$GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH(0,25,"Can't start statement this way with undeclared variable")
β;
β;
[reserved_token]
α INSIDE_STATEMENT←RESERVED_TOKEN_PTR;
IF (statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end)
THEN CASE TYPE_OF_RES_WORD - statement_beg OF
α
redefine xx(str)=[redefine xx_temp="str" & "_P"; xx_temp;];
redefine yy(str)=[];
redefine zz(str)=[redefine zz_temp="str" & "_P"; zz_temp;];
statement_definitions;
β
ELSE IF TOKEN_PTR←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE)
THEN α TYPE_OF_TOKEN←METRIC_TOKEN;
DIM_PTR←TOKEN_PTR; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH(0,3,"Statement can't begin with <"&TOKEN&">");
β
β;
FLUSH:
β "P_STATEMENT";
! execution starts here, initialization;
procedure update_break_RS;
α
ifc full_set thenc
SETBREAK(word_R_break, TABLE1, NULL, "INRF");
SETBREAK(word_S_break, TABLE1, NULL, "INSF");
elsec
SETBREAK(word_R_break, TABLE1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1, NULL, "INSK");
endc
β;
α "execution"
RUNTIME←___TIME;
INITIALIZE←TRUE;
COUNT ← 1000; DELIMITER_1 ← "⊂"; DELIMITER_2 ← "⊃";
OPEN_BRACE← "{" ;
TABLE1 ← "⊂⊃%,.;:[](){}+-*/#∧∨¬⊗&≤≥<>≠=←↑→?|" & lf & cr & dquote & tab & ff & space & squote ;
ifc full_set thenc
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRF");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRF");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSF");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRF");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISF");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAF");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANF");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANF");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANF");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRF");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
SETBREAK(
tty_input_break ← getbreak,ALT,NULL,"IS");
SETBREAK(
knvrt_break ← getbreak,NULL,NULL,"IK");
SETBREAK(
macro_delimiter_break ← getbreak,"⊂⊃",NULL,"IS");
elsec
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRK");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRK");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSK");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRK");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISK");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAK");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANK");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANK");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANK");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRK");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
SETBREAK(
tty_input_break ← getbreak,ALT,NULL,"IS");
SETBREAK(
macro_delimiter_break ← getbreak,"⊂⊃",NULL,"IS");
TTYUP(TRUE);
endc
WANT_DUP_FILE←TRUE;
! set up input and output;
if rpgsw then
α
cmd_line ← tmpin("AL", eof);
if eof
then α usererr(0, 1, "TMPIN lost"); rpgsw ← false β
else outstr(crlf & "AL: ");
β;
if ¬rpgsw then α outstr(crlf & "*"); cmd_line ← instrl(cr) β;
BIN_file ← new_record(file); ALL_file ← new_record(file);
SEX_file ← new_record(file); T←TRUE;
while true do
α "command" define want_BAIL=[switch_setting[b_X]];
want_BAIL ← false;
if ¬T then α outstr(crlf & "*"); cmd_line ← instrl(cr) β; T ← false;
PRESENT_file←AL_file ← scan_command(cmd_line, BIN_file, ALL_file);
if file:eof[AL_file] then
α usererr(0, 1, "null input spec"); continue "command" β;
file:mode[AL_file] ← 0; file:in_bfrs[AL_file] ← 12; file:out_bfrs[AL_file] ← 0;
file:def_ext[AL_file] ← "AL";
if ¬got_input(AL_file) then
α outstr(infile & "file not found"); continue "command" β;
if file:name[BIN_file]=null
then if file:name[AL_file]= null
then file:name[BIN_file]←"ALMAIN"
else file:name[BIN_file]←file:name[AL_file];
copy_file_record(SEX_file, BIN_file);
file:mode[SEX_file] ← 0; file:in_bfrs[SEX_file] ← 0;
file:out_bfrs[SEX_file] ← 12; file:ext[SEX_file] ← "SEX";
if file:eof[SEX_file] then
α "null output spec"
file:device[SEX_file] ← "DSK";
if file:name[AL_file]≠null
then file:name[SEX_file] ← file:name[AL_file]
else file:name[SEX_file] ← "ALMAIN" ;
β "null output spec";
if ¬got_output(SEX_file) then
α usererr(0, 1, "can't get output"); continue "command" β;
outfile←make_file_name(SEX_file);
chanin ← file:chn[AL_file]; chanout ← file:chn[SEX_file];
if equ(file:device[PRESENT_file],"TTY")
then
α
now_top_file←true;
CHECK_WANT_COPY;
now_top_file←false;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
CHANTTYO←-1;
β;
pagenum ← linenum ← sourcelvl ← 0;
typed_page_num ← true;
ifc debug_compile thenc if want_BAIL then BAIL; endc
done "command"
β "command";
ifc dup_file thenc
OPEN_NEW_AL_FILE(BIN_FILE, "NEW");
endc
GET_TOKEN;
IF EQU(CURLINE[1 TO 17],"COMMENT ⊗ VALID")
THEN α GARB←READ(SEMICOLON_A_BREAK); get_token; β;
PARSED_STRING←null; curliner←curline;
! set up predefined dimensions, constants, macros and variables;
redefine zz(temp)=[];
redefine yy(temp,temp2)=[
redefine xx_temp= "DIMENS_EXPONENT:"&"temp"&"["&"temp"&"_DIMENS]←1;";
qq(temp)
xx_temp];
redefine qq(temp)=[redefine xxcount=xxcount+1;
redefine yytemp= "temp"&"_DIMENS←NEW_RECORD(DIMENS_EXPONENT);";
redefine zztemp= "DIMENS_EXPONENT:NAME["&"temp"&"_DIMENS]←"&""""&"temp"&""""&";";
redefine xxtemp(xxxcount)=
"D_TABLE["&"xxxcount" & "] ← INSERT_ENTRY("&""""&"temp"
&""""&",DIMENSION_TYPE_TABLE,"&"temp"&"_DIMENS);";
yytemp
zztemp
xxtemp(xxcount)];
redefine xxcount=-1;
metric_definitions;
INSERT_ENTRY("DIMENSIONLESS",DIMENSION_TYPE_TABLE);
INSERT_ENTRY("VELOCITY",DIMENSION_TYPE_TABLE,
VELOCITY_DIMENS←DIVIDE_DIMENSIONS(DISTANCE_DIMENS,TIME_DIMENS));
INSERT_ENTRY("TORQUE",DIMENSION_TYPE_TABLE,
TORQUE_DIMENS ← MULTIPLY_DIMENSIONS(FORCE_DIMENS,DISTANCE_DIMENS));
INSERT_ENTRY("ANGULAR_VELOCITY",DIMENSION_TYPE_TABLE,
ANGULAR_VELOCITY_DIMENS←DIVIDE_DIMENSIONS(ANGLE_DIMENS,TIME_DIMENS));
FOR I←1 STEP 1 UNTIL const_count DO
α RPTR (ID_LIST) TEMP;
INSERT_ENTRY(PRECONST[I],ID_TYPE_TABLE,TEMP←NEW_RECORD(ID_LIST));
ID_LIST:TYPE[TEMP]←PRECONST_TYPE[I];
ID_LIST:DIMEN[TEMP]←D_TABLE[PRE_DIMENS[I]];
DEFIN(TEMP);
β;
ID_LIST:BODY[CHECK_ENTRY("CRLF",ID_TYPE_TABLE)]← "
";
redefine xx(str1, str2)=[
MACRO_LIST:VALUE[cur_macro←INSERT_ENTRY("str1",MACRO_TYPE_TABLE)]←"str2";
cur_macro←null_record;
];
macro_definitions;
INITIALIZE←FALSE;
! PARSE PROGRAM;
spacing ← 0; print("($PR"); SPACING ← SAVSPACING←1; BLOCK_LEVEL←0;
PRINTOUT;
! **********; P_STATEMENT; ! **********;
IF TOP_SOURCE≠NULL_RECORD OR ¬EQU(INPUT(CHANIN,omit_break),null) THEN
ERROR(200,"Misc. garbage found after last end.");
spacing ← 0; print(")"); printout;
ifc dup_file thenc
IF WANT_DUP_FILE THEN
if chanin > -1 then α out(channew,curliner);
while ¬eof do out(channew,input(chanin,0)); β;
endc
! CLEAN UP;
IF CHANIN>-1 THEN RELEASE(CHANIN);
WHILE TOP_SOURCE≠NULL DO
α
IF SOURCE_LIST:CHAN[TOP_SOURCE]>-1
THEN α out(channew, curliner); while ¬eof do out(channew,input(chanin,0));
RELEASE(SOURCE_LIST:CHAN[TOP_SOURCE]); β;
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β;
CLOSO(CHANOUT);
CLOSO(CHANLOG);
IF CHANTTYO>-1 THEN CLOSO(CHANTTYO);
ifc dup_file thenc
IF WANT_DUP_FILE AND (NUM_OF_ERRORS_MODIFIED>0)
THEN IF ASK_WANT_DUP_FILE THEN CLOSO(CHANNEW);
endc
RUNTIME←___TIME - RUNTIME;
OUTSTR(CRLF & "PARSING TIME = "&CVS(RUNTIME)& " MSECS");
IF NUM_OF_ERRORS > 0 THEN
α
OUTSTR(crlf & "Number of errors found = "& cvs(NUM_OF_ERRORS));
OUTSTR(CRLF & "Number of errors modified = "& cvs(NUM_OF_ERRORS_MODIFIED));
β;
β "execution";
! SWAP TO AL COMPILER;
α "swap" integer array swap[0:10]; string s; integer tmperr;
if length(file:ext[BIN_file])=0 then file:ext[BIN_file] ← "BIN";
s ← make_file_name(BIN_file) & "," & make_file_name(ALL_file) & "←" & outfile;
α "switches_for_ALC" boolean seen_one; integer i;
seen_one ← false;
for i ← 0 step 1 until switch_max do
if switch_setting[i] then
α
if ¬seen_one then α s ← s & "("; seen_one ← true β;
s ← s & switch_name[i];
β;
if ¬equ(switch_name[switch_max+1],NULL) then
if seen_one then s←s&switch_name[switch_max+1]
else s←s& "(" &switch_name[switch_max+1]&")";
if seen_one then s ← s & ")";
β "switches_for_ALC";
! if switch_setting[N_X] then tmpout("ALCNEW", s, tmperr) else tmpout("ALC", s, tmperr);
tmpout("ALC", s, tmperr);
if tmperr then usererr(0, 1, "Trouble with TMPOUT");
outstr(crlf);
swap[0] ← cvsix("DSK");
if switch_setting[N_X]
then swap[1] ← cvfil("ALCNEW.DMP[AL,HE]", swap[2], swap[4])
else swap[1] ← cvfil("ALC.DMP[AL,HE]", swap[2], swap[4]);
swap[3] ← 1; ! start job in RPG mode; swap[5] ← 0;
call(location(swap[0]), "SWAP");
β "swap";
IFC FALSE THENC
β "hidden_parse";
HIDDEN_PARSE;
ENDC
END "PARSE";